How to assert what given method pointer uses stdcall calling convention? - delphi

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.

Related

Access Violation if RTTI is accessed inside package

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.

Unable to invoke method declare in class implement generic interface method

Delphi support generic for IInterface. I have the follow construct using generic IInterface:
type
IVisitor<T> = interface
['{9C353AD4-6A3A-44FD-B924-39B86A4CB14D}']
procedure Visit(o: T);
end;
TMyVisitor = class(TInterfacedObject, IVisitor<TButton>, IVisitor<TEdit>)
procedure Visit(o: TButton); overload;
procedure Visit(o: TEdit); overload;
end;
implementation
procedure TMyVisitor.Visit(o: TButton);
begin
ShowMessage('Expected: TButton, Actual: ' + o.ClassName);
end;
procedure TMyVisitor.Visit(o: TEdit);
begin
ShowMessage('Expected: TEdit, Actual: ' + o.ClassName);
end;
TMyVisitor class implement two interface: IVisitor<TButton> and IVisitor<TEdit>.
I attempt invoke the methods:
procedure TForm6.Button1Click(Sender: TObject);
var V: IInterface;
begin
V := TMyVisitor.Create;
(V as IVisitor<TButton>).Visit(Button1);
(V as IVisitor<TEdit>).Visit(Edit1);
end;
The output I have is:
Expected: TEdit, Actual: TButton
Expected: TEdit, Actual: TEdit
Apparently, the code doesn't invoke procedure TMyVisitor.Visit(o: TButton) when execute (V as IVisitor<TButton>).Visit(Button1).
Is this a bug in Delphi or I should avoid implement multiple generic IInterface? All above codes have test in Delphi XE6.
as operator requires interface GUID to be able to tell which interface you are referring to. Since generic interfaces share same GUID as operator will not work with them. Basically, compiler cannot tell the difference between IVisitor<TButton> and IVisitor<TEdit> interfaces.
However, you can solve your problem using enhanced RTTI:
type
TCustomVisitor = class(TObject)
public
procedure Visit(Instance: TObject);
end;
TVisitor = class(TCustomVisitor)
public
procedure VisitButton(Instance: TButton); overload;
procedure VisitEdit(Instance: TEdit); overload;
end;
procedure TCustomVisitor.Visit(Instance: TObject);
var
Context: TRttiContext;
CurrentClass: TClass;
Params: TArray<TRttiParameter>;
ParamType: TRttiType;
SelfMethod: TRttiMethod;
s: string;
begin
Context := TRttiContext.Create;
CurrentClass := Instance.ClassType;
repeat
s := CurrentClass.ClassName;
Delete(s, 1, 1); // remove "T"
for SelfMethod in Context.GetType(Self.ClassType).GetMethods('Visit' + s) do
begin
Params := SelfMethod.GetParameters;
if (Length(Params) = 1) then
begin
ParamType := Params[0].ParamType;
if ParamType.IsInstance and (ParamType.AsInstance.MetaclassType = CurrentClass) then
begin
SelfMethod.Invoke(Self, [Instance]);
Exit;
end;
end;
end;
CurrentClass := CurrentClass.ClassParent;
until CurrentClass = nil;
end;
If you need to have Visitor interface you can change declarations to
type
IVisitor = interface
['{9C353AD4-6A3A-44FD-B924-39B86A4CB14D}']
procedure Visit(Instance: TObject);
end;
TCustomVisitor = class(TInterfacedObject, IVisitor)
public
procedure Visit(Instance: TObject);
end;
You can then use that in following manner, just by calling Visit and appropriate Visit method will be called.
procedure TForm6.Button1Click(Sender: TObject);
var V: IVisitor;
begin
V := TMyVisitor.Create;
V.Visit(Button1);
V.Visit(Edit1);
end;
Above code is based on Uwe Raabe's code and you can read more http://www.uweraabe.de/Blog/?s=visitor
And here is extended visitor interface and class that can operate on non-class types. I have implemented only calls for string, but implementation for other types consists only of copy-paste code with different typecast.
IVisitor = interface
['{9C353AD4-6A3A-44FD-B924-39B86A4CB14D}']
procedure Visit(const Instance; InstanceType: PTypeInfo);
procedure VisitObject(Instance: TObject);
end;
TCustomVisitor = class(TInterfacedObject, IVisitor)
public
procedure Visit(const Instance; InstanceType: PTypeInfo);
procedure VisitObject(Instance: TObject);
end;
procedure TCustomVisitor.Visit(const Instance; InstanceType: PTypeInfo);
var
Context: TRttiContext;
Params: TArray<TRttiParameter>;
ParamType: TRttiType;
SelfMethod: TRttiMethod;
begin
Context := TRttiContext.Create;
case InstanceType.Kind of
tkClass : VisitObject(TObject(Instance));
// template how to implement calls for non-class types
tkUString :
begin
for SelfMethod in Context.GetType(Self.ClassType).GetMethods('VisitString') do
begin
Params := SelfMethod.GetParameters;
if (Length(Params) = 1) then
begin
ParamType := Params[0].ParamType;
if ParamType.TypeKind = tkUString then
begin
SelfMethod.Invoke(Self, [string(Instance)]);
Exit;
end;
end;
end;
end;
end;
end;
procedure TCustomVisitor.VisitObject(Instance: TObject);
var
Context: TRttiContext;
CurrentClass: TClass;
Params: TArray<TRttiParameter>;
ParamType: TRttiType;
SelfMethod: TRttiMethod;
s: string;
begin
Context := TRttiContext.Create;
CurrentClass := Instance.ClassType;
repeat
s := CurrentClass.ClassName;
Delete(s, 1, 1); // remove "T"
for SelfMethod in Context.GetType(Self.ClassType).GetMethods('Visit' + s) do
begin
Params := SelfMethod.GetParameters;
if (Length(Params) = 1) then
begin
ParamType := Params[0].ParamType;
if ParamType.IsInstance and (ParamType.AsInstance.MetaclassType = CurrentClass) then
begin
SelfMethod.Invoke(Self, [Instance]);
Exit;
end;
end;
end;
CurrentClass := CurrentClass.ClassParent;
until CurrentClass = nil;
end;
Enhanced Visitor can be used like this:
TVisitor = class(TCustomVisitor)
public
procedure VisitButton(Instance: TButton); overload;
procedure VisitEdit(Instance: TEdit); overload;
procedure VisitString(Instance: string); overload;
end;
var
v: IVisitor;
s: string;
begin
s := 'this is string';
v := TVisitor.Create;
// class instances can be visited directly via VisitObject
v.VisitObject(Button1);
v.Visit(Edit1, TypeInfo(TEdit));
v.Visit(s, TypeInfo(string));
end;
This is a well known problem with generic interfaces. Here is yours:
type
IVisitor<T> = interface
['{9C353AD4-6A3A-44FD-B924-39B86A4CB14D}']
procedure Visit(o: T);
end;
Now, the as operator is implemented on top of the GUID that you specify for the interface. When you write:
(V as IVisitor<TButton>).Visit(Button1);
(V as IVisitor<TEdit>).Visit(Edit1);
how can the as operator distinguish between IVisitor<TButton> and IVisitor<TEdit>? You have only specified a single GUID. In fact when this happens, all instantiated types based on this generic interface share the same GUID. And so whilst the as operator compiles, and the code executes, the runtime behaviour is ill-defined. In effect you are defining multiple interfaces and giving them all the same GUID.
So, the fundamental issue here is that the as operator is not compatible with generic interfaces. You will have to find some other way to implement this. You might consider looking at the Spring4D project for inspiration.

In Delphi XE3, how can I cast a TVirtualInterface object to its interface, using TypeInfo or RTTI?

I'm trying to use TVirtualInterface. I've mostly tried to follow the examples at the Embarcadero doc wiki and at Nick Hodges' blog.
However, What I'm trying to do is a little bit different from the standard examples.
I have simplified the following sample code as much as I can to illustrate what I am trying to do. I have left out obvious validation and error handling code.
program VirtualInterfaceTest;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.Generics.Collections,
System.Rtti,
System.SysUtils,
System.TypInfo;
type
ITestData = interface(IInvokable)
['{6042BB6F-F30C-4C07-8D3B-C123CF1FF60F}']
function GetComment: string;
procedure SetComment(const Value: string);
property Comment: string read GetComment write SetComment;
end;
IMoreData = interface(IInvokable)
['{1D2262CE-09F4-45EC-ACD8-3EEE6B2F1548}']
function GetSuccess: Boolean;
procedure SetSuccess(const Value: Boolean);
property Success: Boolean read GetSuccess write SetSuccess;
end;
TDataHolder = class
private
FTestData: ITestData;
FMoreData: IMoreData;
public
property TestData: ITestData read FTestData write FTestData;
property MoreData: IMoreData read FMoreData write FMoreData;
end;
TVirtualData = class(TVirtualInterface)
private
FData: TDictionary<string, TValue>;
procedure DoInvoke(Method: TRttiMethod;
const Args: TArray<TValue>;
out Result: TValue);
public
constructor Create(PIID: PTypeInfo);
destructor Destroy; override;
end;
constructor TVirtualData.Create(PIID: PTypeInfo);
begin
inherited Create(PIID, DoInvoke);
FData := TDictionary<string, TValue>.Create;
end;
destructor TVirtualData.Destroy;
begin
FData.Free;
inherited Destroy;
end;
procedure TVirtualData.DoInvoke(Method: TRttiMethod;
const Args: TArray<TValue>;
out Result: TValue);
var
key: string;
begin
if (Pos('Get', Method.Name) = 1) then
begin
key := Copy(Method.Name, 4, MaxInt);
FData.TryGetValue(key, Result);
end;
if (Pos('Set', Method.Name) = 1) then
begin
key := Copy(Method.Name, 4, MaxInt);
FData.AddOrSetValue(key, Args[1]);
end;
end;
procedure InstantiateData(obj: TObject);
var
rttiContext: TRttiContext;
rttiType: TRttiType;
rttiProperty: TRttiProperty;
propertyType: PTypeInfo;
data: IInterface;
value: TValue;
begin
rttiContext := TRttiContext.Create;
try
rttiType := rttiContext.GetType(obj.ClassType);
for rttiProperty in rttiType.GetProperties do
begin
propertyType := rttiProperty.PropertyType.Handle;
data := TVirtualData.Create(propertyType) as IInterface;
value := TValue.From<IInterface>(data);
// TValueData(value).FTypeInfo := propertyType;
rttiProperty.SetValue(obj, value); // <<==== EInvalidCast
end;
finally
rttiContext.Free;
end;
end;
procedure Test_UsingDirectInstantiation;
var
dataHolder: TDataHolder;
begin
dataHolder := TDataHolder.Create;
try
dataHolder.TestData := TVirtualData.Create(TypeInfo(ITestData)) as ITestData;
dataHolder.MoreData := TVirtualData.Create(TypeInfo(IMoreData)) as IMoreData;
dataHolder.TestData.Comment := 'Hello World!';
dataHolder.MoreData.Success := True;
Writeln('Comment: ', dataHolder.TestData.Comment);
Writeln('Success: ', dataHolder.MoreData.Success);
finally
dataHolder.Free;
end;
end;
procedure Test_UsingIndirectInstantiation;
var
dataHolder: TDataHolder;
begin
dataHolder := TDataHolder.Create;
try
InstantiateData(dataHolder); // <<====
dataHolder.TestData.Comment := 'Hello World!';
dataHolder.MoreData.Success := False;
Writeln('Comment: ', dataHolder.TestData.Comment);
Writeln('Success: ', dataHolder.MoreData.Success);
finally
dataHolder.Free;
end;
end;
begin
try
Test_UsingDirectInstantiation;
Test_UsingIndirectInstantiation;
except on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
I have some arbitrary interfaces with read/write properties, ITestData and IMoreData, and a class that holds references to these interfaces, IDataHolder.
I have created a class, TVirtualData, that inherits from TVirtualInterface, following Nick Hodges' examples. And when I use this class the way I see it in all the examples, as in Test_UsingDirectInstantiation, it works swell.
What my code needs to do, however, is instantiate the interfaces in a more indirect manner, as in Test_UsingIndirectInstantiation.
The InstantiateData method uses RTTI, and works well up until the SetValue call which throws an EInvalidCast exception ("Invalid class typecast").
I added in the commented line (which I saw in some sample code from "Delphi Sorcery") to try to cast the data object to the appropriate interface. This allowed the SetValue call to run cleanly, but when I tried to access the interface property (i.e. dataHolder.TestData.Comment) it threw a EAccessViolation exception ("Access violation at address 00000000. Read of address 00000000").
For fun I replace IInterface in the InstantiateData method with ITestData, and for the first property it worked fine, but naturally, it didn't work for the second property.
Question: Is there a way to dynamically cast this TVirtualInterface object to the appropriate interface using TypeInfo or RTTI (or something else) so that the InstantiateData method has the same effect as setting the properties directly?
First you have to cast the instance to the correct interface and not IInterface. You can still store it in an IInterface variable though but it really containes the reference to the correct interface type.
Then you have to put that into a TValue with the correct type and not IInterface (RTTI is very strict about types)
The commented line you added was just to work around the second but as it was really containing the IInterface reference (and not a ITestData or TMoreData references) it resulted on the AV.
procedure InstantiateData(obj: TObject);
var
rttiContext: TRttiContext;
rttiType: TRttiType;
rttiProperty: TRttiProperty;
propertyType: PTypeInfo;
data: IInterface;
value: TValue;
begin
rttiType := rttiContext.GetType(obj.ClassType);
for rttiProperty in rttiType.GetProperties do
begin
propertyType := rttiProperty.PropertyType.Handle;
Supports(TVirtualData.Create(propertyType), TRttiInterfaceType(rttiProperty.PropertyType).GUID, data);
TValue.Make(#data, rttiProperty.PropertyType.Handle, value);
rttiProperty.SetValue(obj, value);
end;
end;

Interfaces without reference counting

After reading many post on StackOverflow about the cons of using automatic reference counting for Interfaces, I started trying to manually reference counting each interface instantiation.
After trying for a full afternoon I give up!
Why do I get Access Violation when I call FreeAndNil(p)?
What follow is a complete listing of my simple unit.
unit fMainForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm4 = class(TForm)
btn1: TButton;
procedure FormCreate(Sender: TObject);
procedure btn1Click(Sender: TObject);
end;
type
IPersona = interface(IInterface)
['{44483AA7-2A22-41E6-BA98-F3380184ACD7}']
function GetNome: string;
procedure SetNome(const Value: string);
property Nome: string read GetNome write SetNome;
end;
type
TPersona = class(TObject, IPersona)
strict private
FNome: string;
function GetNome: string;
procedure SetNome(const Value: string);
protected
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
public
constructor Create(const ANome: string);
destructor Destroy; override;
end;
var
Form4: TForm4;
implementation
{$R *.dfm}
procedure TForm4.FormCreate(Sender: TObject);
begin
ReportMemoryLeaksOnShutdown := True;
end;
procedure TForm4.btn1Click(Sender: TObject);
var
p: IPersona;
begin
p := TPersona.Create('Fabio');
try
ShowMessage(p.Nome);
finally
FreeAndNil(p);
end;
end;
constructor TPersona.Create(const ANome: string);
begin
inherited Create;
FNome := ANome;
end;
destructor TPersona.Destroy;
begin
inherited Destroy;
end;
function TPersona._AddRef: Integer;
begin
Result := -1
end;
function TPersona._Release: Integer;
begin
Result := -1
end;
function TPersona.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := S_OK
else
Result := E_NOINTERFACE;
end;
function TPersona.GetNome: string;
begin
Result := FNome;
end;
procedure TPersona.SetNome(const Value: string);
begin
FNome := Value;
end;
end.
The access violation occurs because FreeAndNil receives an untyped var parameter that is expected to be an object reference. You are passing an interface reference which does not meet the requirement. Unfortunately you only find out at runtime. This is, in my view, the strongest point against the use of FreeAndNil.
Your reference counting disables lifetime management by the interface reference counting mechanism. In order to destroy an object you need to call its destructor. And in order to do that you must have access to the destructor. Your interface doesn't expose the destructor (and it should not). So, we can deduce that, in order to destroy the object, you need to have an object reference.
Here are some options:
var
obj: TPersona;
intf: IPersona;
....
obj := TPersona.Create('Fabio');
try
intf := obj;
//do stuff with intf
finally
obj.Free;
// or FreeAndNil(obj) if you prefer
end;
Or you can do it like this
var
intf: IPersona;
....
intf := TPersona.Create('Fabio');
try
//do stuff with intf
finally
(intf as TObject).Free;
end;
You cannot use FreeAndNil() with an interface reference, only an objct reference. Had you left the interface's reference count enabled, you would simply assign nil to the interface reference (or just let it go out of scope) to free the object correctly, eg:
type
TPersona = class(TInterfacedObject, IPersona)
strict private
FNome: string;
function GetNome: string;
procedure SetNome(const Value: string);
public
constructor Create(const ANome: string);
destructor Destroy; override;
end;
procedure TForm4.btn1Click(Sender: TObject);
var
p: IPersona;
begin
p := TPersona.Create('Fabio');
try
ShowMessage(p.Nome);
finally
p := nil;
end;
end;
But since you have disabled the reference count on the interface, you need to go back to using normal object reference variables in your code, eg:
procedure TForm4.btn1Click(Sender: TObject);
var
p: TPersona;
intf: IPersona;
begin
p := TPersona.Create('Fabio');
try
if Supports(p, IPersona, intf) then
ShowMessage(intf.Nome);
finally
FreeAndNil(p);
end;
end;

What is the fastest XML Parser available for Delphi?

We have reasonably large XML strings which we currently parse using MSXML2
I have just tried using MSXML6 hoping for a speed improvement and have got nothing!
We currently create a lot of DOM Documents and I guess there may be some overhead in constantly interacting with the MSXML2/6 dll
Does anyone know of a better/faster XML component for Delphi?
If anyone can suggest an alternative, and it is faster, we would look to integrate it, but that would be a lot of work, so hopefully the structure would not be too different to that used by MSXML
We are using Delphi 2010
Paul
some time ago I had to serialize record to XML format; for ex:
TTest = record
a : integer;
b : real;
end;
to
<Data>
<a type="tkInteger">value</a>
<b type="tkFloat">value</b>
</Data>
I used RTTI to recursively navigate through record fields and storing values to XML.
I've tried few XML Parsers. I did't need DOM model to create xml, but needed it to load it back.
XML contained about 310k nodes (10-15MBytes);
results presented in table below, there are 6 columns with time in seconds;
1 - time for creating nodes and write values
2 - SaveToFile();
3 = 1 + 2
4 - LoadFromFile();
5 - navigate through nodes and read values
6 = 4 + 5
MSXML/Xerces/ADOM - are differend vendors for TXMLDocument (DOMVendor)
JanXML doesn't work with unicode; I fixed some errors, and saved XML, but loading causes AV (or stack overflow, I don't remember);
manual - means manually writing XML using TStringStream.
I used Delphi2010, Win7x32, Q8200 CPU/2.3GHz, 4Gb of RAM.
update: You can download source code for this test (record serialization to XML using RTTI) here http://blog.karelia.pro/teran/files/2012/03/XMLTest.zip All parsers (Omni, Native, Jan) are included (now nodes count in XML is about 270k), sorry there are no comments in code.
I know that it's an old question, but people might find it interesting:
I wrote a new XML library for Delphi (OXml): http://www.kluug.net/oxml.php
It features direct XML handling (read+write), SAX parser, DOM and a sequential DOM parser.
One of the benefits is that OXml supports Delphi 6-Delphi XE5, FPC/Lazarus and C++Builder on all platforms (Win, MacOSX, Linux, iOS, Android).
OXml DOM is record/pointer based and offers better performance than any other XML library:
The read test returns the time the parser needs to read a custom XML DOM from a file (column "load") and to write node values to a constant dummy function (column "navigate").
The file is encoded in UTF-8 and it's size is about 5,6 MB.
The write test returns the time the parser needs to create a DOM (column "create") and write this DOM to a file (column "save").
The file is encoded in UTF-8 and it's size is about 11 MB.
+ The poor OmniXML (original) writing performance was the result of the fact that OmniXML didn't use buffering for writing. Thus writing to a TFileStream was very slow. I updated OmniXML and added buffering support. You can get the latest OmniXML code from the SVN.
Recently I had a similar issue where using the MSXML DOM parser proved to be too slow for the given task. I had to parse rather large documents > 1MB and the memory consumption of the DOM parser was prohibitive.
My solution was to not use a DOM parser at all, but to go with the event driven MSXML SAX parser. This proved to be much, much faster. Unfortunately the programming model is totally different, but dependent on the task, it might be worth it.
Craig Murphy has published an excellent article on how to use the MSXML SAX parser in delphi:
SAX, Delphi and Ex Em El
Someday I have written very simple XML test suite. It serves MSXML (D7 MSXML3?), Omni XML (bit old) and Jedi XML (latest stable).
Test results for 1,52 MB file:
XML file loading time MSXML: 240,20 [ms]
XML node selections MSXML: 1,09 [s]
XML file loading time OmniXML: 2,25 [s]
XML node selections OmniXML: 1,22 [s]
XML file loading time JclSimpleXML: 2,11 [s]
and access violation for JclSimpleXML node selections :|
Unfortunately I actually haven't much time to correct above AV, but sorces are contained below...
fmuMain.pas
program XmlEngines;
uses
FastMM4,
Forms,
fmuMain in 'fmuMain.pas' {fmMain},
uXmlEngines in 'uXmlEngines.pas',
ifcXmlEngine in 'ifcXmlEngine.pas';
{$R *.res}
begin
Application.Initialize;
Application.Title := 'XML Engine Tester';
Application.CreateForm(TfmMain, fmMain);
Application.Run;
end.
fmuMain.pas
unit fmuMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, xmldom, XMLIntf, msxmldom, XMLDoc,
//
ifcXmlEngine, StdCtrls;
type
TfmMain = class(TForm)
mmoDebug: TMemo;
dlgOpen: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure mmoDebugClick(Sender: TObject);
private
fXmlEngines: TInterfaceList;
function Get_Engine(const aIx: Integer): IXmlEngine;
protected
property XmlEngine[const aIx: Integer]: IXmlEngine read Get_Engine;
procedure Debug(const aInfo: string); // inline
public
procedure RegisterXmlEngine(const aEngine: IXmlEngine);
end;
var
fmMain: TfmMain;
implementation
{$R *.dfm}
uses
uXmlEngines, TZTools;
{ TForm1 }
function TfmMain.Get_Engine(const aIx: Integer): IXmlEngine;
begin
Result:= nil;
Supports(fXmlEngines[aIx], IXmlEngine, Result)
end;
procedure TfmMain.RegisterXmlEngine(const aEngine: IXmlEngine);
var
Ix: Integer;
begin
if aEngine = nil then
Exit; // WARRNING: program flow disorder
for Ix:= 0 to Pred(fXmlEngines.Count) do
if XmlEngine[Ix] = aEngine then
Exit; // WARRNING: program flow disorder
fXmlEngines.Add(aEngine)
end;
procedure TfmMain.FormCreate(Sender: TObject);
begin
fXmlEngines:= TInterfaceList.Create();
dlgOpen.InitialDir:= ExtractFileDir(ParamStr(0));
RegisterXmlEngine(TMsxmlEngine.Create(Self));
RegisterXmlEngine(TOmniXmlEngine.Create());
RegisterXmlEngine(TJediXmlEngine.Create());
end;
procedure TfmMain.mmoDebugClick(Sender: TObject);
procedure TestEngines(const aFilename: TFileName);
procedure TestEngine(const aEngine: IXmlEngine);
var
PerfCheck: TPerfCheck;
Ix: Integer;
begin
PerfCheck := TPerfCheck.Create();
try
PerfCheck.Init(True);
PerfCheck.Start();
aEngine.Load(aFilename);
PerfCheck.Pause();
Debug(Format(
'XML file loading time %s: %s',
[aEngine.Get_ID(), PerfCheck.TimeStr()]));
if aEngine.Get_ValidNode() then
begin
PerfCheck.Start();
for Ix:= 0 to 999999 do
if aEngine.Get_ChildsCount() > 0 then
begin
aEngine.SelectChild(Ix mod aEngine.Get_ChildsCount());
end
else
aEngine.SelectRootNode();
PerfCheck.Pause();
Debug(Format(
'XML nodes selections %s: %s',
[aEngine.Get_ID(), PerfCheck.TimeStr()]));
end
finally
PerfCheck.Free();
end
end;
var
Ix: Integer;
begin
Debug(aFilename);
for Ix:= 0 to Pred(fXmlEngines.Count) do
TestEngine(XmlEngine[Ix])
end;
var
CursorBckp: TCursor;
begin
if dlgOpen.Execute() then
begin
CursorBckp:= Cursor;
Self.Cursor:= crHourGlass;
mmoDebug.Cursor:= crHourGlass;
try
TestEngines(dlgOpen.FileName)
finally
Self.Cursor:= CursorBckp;
mmoDebug.Cursor:= CursorBckp;
end
end
end;
procedure TfmMain.Debug(const aInfo: string);
begin
mmoDebug.Lines.Add(aInfo)
end;
procedure TfmMain.FormDestroy(Sender: TObject);
begin
fXmlEngines.Free()
end;
end.
ifcXmlEngine.pas
unit ifcXmlEngine;
interface
uses
SysUtils;
type
TFileName = SysUtils.TFileName;
IXmlEngine = interface
['{AF77333B-9873-4FDE-A3B1-260C7A4D3357}']
procedure Load(const aFilename: TFileName);
procedure SelectRootNode();
procedure SelectChild(const aIndex: Integer);
procedure SelectParent();
//
function Get_ID(): string;
function Get_ValidNode(): Boolean;
function Get_ChildsCount(): Integer;
function Get_HaveParent(): Boolean;
//function Get_NodeName(): Boolean;
end;
implementation
end.
uXmlEngines.pas
unit uXmlEngines;
interface
uses
Classes,
//
XMLDoc, XMLIntf, OmniXml, JclSimpleXml,
//
ifcXmlEngine;
type
TMsxmlEngine = class(TInterfacedObject, IXmlEngine)
private
fXmlDoc: XMLDoc.TXMLDocument;
fNode: XMLIntf.IXMLNode;
protected
public
constructor Create(const aOwner: TComponent);
destructor Destroy; override;
procedure Load(const aFilename: TFileName);
procedure SelectRootNode();
procedure SelectChild(const aIndex: Integer);
procedure SelectParent();
//
function Get_ID(): string;
function Get_ValidNode(): Boolean;
function Get_ChildsCount(): Integer;
function Get_HaveParent(): Boolean;
//function Get_NodeName(): Boolean;
end;
TOmniXmlEngine = class(TInterfacedObject, IXmlEngine)
private
fXmlDoc: OmniXml.IXmlDocument;
fNode: OmniXml.IXMLNode;
protected
public
constructor Create;
destructor Destroy; override;
procedure Load(const aFilename: TFileName);
procedure SelectRootNode();
procedure SelectChild(const aIndex: Integer);
procedure SelectParent();
//
function Get_ID(): string;
function Get_ValidNode(): Boolean;
function Get_ChildsCount(): Integer;
function Get_HaveParent(): Boolean;
//function Get_NodeName(): Boolean;
end;
TJediXmlEngine = class(TInterfacedObject, IXmlEngine)
private
fXmlDoc: TJclSimpleXML;
fNode: TJclSimpleXMLElem;
protected
public
constructor Create();
destructor Destroy(); override;
procedure Load(const aFilename: TFileName);
procedure SelectRootNode();
procedure SelectChild(const aIndex: Integer);
procedure SelectParent();
//
function Get_ID(): string;
function Get_ValidNode(): Boolean;
function Get_ChildsCount(): Integer;
function Get_HaveParent(): Boolean;
//function Get_NodeName(): Boolean;
end;
implementation
uses
SysUtils;
{ TMsxmlEngine }
constructor TMsxmlEngine.Create(const aOwner: TComponent);
begin
if aOwner = nil then
raise Exception.Create('TMsxmlEngine.Create() -> invalid owner');
inherited Create();
fXmlDoc:= XmlDoc.TXmlDocument.Create(aOwner);
fXmlDoc.ParseOptions:= [poPreserveWhiteSpace]
end;
destructor TMsxmlEngine.Destroy;
begin
fXmlDoc.Free();
inherited Destroy()
end;
function TMsxmlEngine.Get_ChildsCount: Integer;
begin
Result:= fNode.ChildNodes.Count
end;
function TMsxmlEngine.Get_HaveParent: Boolean;
begin
Result:= fNode.ParentNode <> nil
end;
function TMsxmlEngine.Get_ID: string;
begin
Result:= 'MSXML'
end;
//function TMsxmlEngine.Get_NodeName: Boolean;
//begin
// Result:= fNode.Text
//end;
function TMsxmlEngine.Get_ValidNode: Boolean;
begin
Result:= fNode <> nil
end;
procedure TMsxmlEngine.Load(const aFilename: TFileName);
begin
fXmlDoc.LoadFromFile(aFilename);
SelectRootNode()
end;
procedure TMsxmlEngine.SelectChild(const aIndex: Integer);
begin
fNode:= fNode.ChildNodes.Get(aIndex)
end;
procedure TMsxmlEngine.SelectParent;
begin
fNode:= fNode.ParentNode
end;
procedure TMsxmlEngine.SelectRootNode;
begin
fNode:= fXmlDoc.DocumentElement
end;
{ TOmniXmlEngine }
constructor TOmniXmlEngine.Create;
begin
inherited Create();
fXmlDoc:= OmniXml.TXMLDocument.Create();
fXmlDoc.PreserveWhiteSpace:= true
end;
destructor TOmniXmlEngine.Destroy;
begin
fXmlDoc:= nil;
inherited Destroy()
end;
function TOmniXmlEngine.Get_ChildsCount: Integer;
begin
Result:= fNode.ChildNodes.Length
end;
function TOmniXmlEngine.Get_HaveParent: Boolean;
begin
Result:= fNode.ParentNode <> nil
end;
function TOmniXmlEngine.Get_ID: string;
begin
Result:= 'OmniXML'
end;
//function TOmniXmlEngine.Get_NodeName: Boolean;
//begin
// Result:= fNode.NodeName
//end;
function TOmniXmlEngine.Get_ValidNode: Boolean;
begin
Result:= fNode <> nil
end;
procedure TOmniXmlEngine.Load(const aFilename: TFileName);
begin
fXmlDoc.Load(aFilename);
SelectRootNode()
end;
procedure TOmniXmlEngine.SelectChild(const aIndex: Integer);
begin
fNode:= fNode.ChildNodes.Item[aIndex]
end;
procedure TOmniXmlEngine.SelectParent;
begin
fNode:= fNode.ParentNode
end;
procedure TOmniXmlEngine.SelectRootNode;
begin
fNode:= fXmlDoc.DocumentElement
end;
{ TJediXmlEngine }
constructor TJediXmlEngine.Create;
begin
inherited Create();
fXmlDoc:= TJclSimpleXML.Create();
end;
destructor TJediXmlEngine.Destroy;
begin
fXmlDoc.Free();
inherited Destroy()
end;
function TJediXmlEngine.Get_ChildsCount: Integer;
begin
Result:= fNode.ChildsCount
end;
function TJediXmlEngine.Get_HaveParent: Boolean;
begin
Result:= fNode.Parent <> nil
end;
function TJediXmlEngine.Get_ID: string;
begin
Result:= 'JclSimpleXML';
end;
//function TJediXmlEngine.Get_NodeName: Boolean;
//begin
// Result:= fNode.Name
//end;
function TJediXmlEngine.Get_ValidNode: Boolean;
begin
Result:= fNode <> nil
end;
procedure TJediXmlEngine.Load(const aFilename: TFileName);
begin
fXmlDoc.LoadFromFile(aFilename);
SelectRootNode()
end;
procedure TJediXmlEngine.SelectChild(const aIndex: Integer);
begin
fNode:= fNode.Items[aIndex]
end;
procedure TJediXmlEngine.SelectParent;
begin
fNode:= fNode.Parent
end;
procedure TJediXmlEngine.SelectRootNode;
begin
fNode:= fXmlDoc.Root
end;
end.
Give a try to himXML by himitsu.
It is released under MPL v1.1 , GPL v3.0 or LGPL v3.0 license.
You will have to register to the Delphi-Praxis (german) excellent Delphi site so as to be able to download:
himxml_246.7z
It has a very impressive performance and the distribution includes demos demonstrating that. I've successfully used it in Delphi 2007, Delphi 2010 and Delphi XE.

Resources