I noticed a strange bug with the TVirtualInterface class.
I tried something like following :
ITest1 = interface
procedure Test1();
End;
ITest2 = Interface(ITest1)
procedure Test2();
End;
ITest3 = Interface(ITest2)
procedure Test3();
ENd;
procedure Test();
var
test : ITest3;
begin
test := TVirtualInterface(TypeInfo(ITest3),
procedure(Method: TRttiMethod;
const Args: TArray<TValue>; out Result: TValue)
begin
showMessage(Method.Name);
end) as ITest3;
test.test1();
test.test2();
test.test3();
End;
The code above works fine. If i change it like this :
ITest3 = Interface(ITest2)
procedure Test3();
function GetLabel : string;
property Label : string read GetLabel;
ENd;
and i call :
showmessage(test.Label);
... it still works.
But if i move this property to ITest2 or ITest1, calls to some methods of any of ITest1, ITest2 or ITest3 will either call the wrong method (for example test.Test2() will display "Test3"), either crash (access violation).
Any explanation and/or fix to this ?
Edit >> Sorry, actually it actually seems to fail only with properties of the kind :
property Item[Name : string] : X read GetX write SetX;
This is bug in Delphi XE3 compiler and it is fixed in XE4
Fix list for RAD Studio XE4
104613 TVirtualInterface: TRttiMethod for indexed property in interfaces
Have you tried inheriting interfaces from IInvokable and provide them with GUID like in Embarcadero example
My guess is there is some issues with interface RTTI if it is not inherited from IInvokable
Related
I am new to DUnitx and Delphi-Mocks so please be patient. The only other post I could find on this topic was 3 years old and not answered. Returning records in Delphi-Mocks
Delphi Rio 10.3.
Windows 10
I want to test this procedure:
procedure TdmMariaDBConnection.Notify;
var
LViewModel : IPsViewModel;
begin
FMainViewModel.HandleCommands(FCommandRecord);
for LViewModel in FObservers do
LViewModel.HandleCommands(FCommandRecord);
end;
The interfaces and record type are declared as:
IPsView = interface(IInvokable)
['{F5532762-09F8-42C4-9F9F-A8F7FF7FA0C6}']
procedure HandleCommands(const Value: TPsCommandRecord);
procedure AfterCreate;
procedure BeforeDestroy;
end;
IPsViewModel = interface(IInvokable)
['{322DAB08-6A7C-4B61-B656-BC5346ACFC14}']
procedure HandleCommands(const Value: TPsCommandRecord);
end;
IPsMainViewModel = interface(IInvokable)
['{98FFB416-6C22-492F-BC85-D9A1ECA667FE}']
procedure Attach(const observer: IPsView);
procedure Notify;
procedure LoadFrame(const Value: TPanel);
procedure LoadForm(const Value: integer);
procedure LoadModalForm(const Value: integer);
procedure HandleCommands(const Value: TPsCommandRecord);
procedure SetViewFactory(Value: IPsViewFactory);
property ViewFactory: IPsViewFactory write SetViewFactory;
end;
TPsCommandRecord = record
CommandType: integer;
CommandObject: TObject;
CommandMessage: TPsTaskDialogMessageRecord;
end;
I have the Notify procedure in the protected section
type
TdmMariaDBConnection = class(TDataModule, IPsModel)
procedure DataModuleDestroy(Sender: TObject);
procedure DataModuleCreate(Sender: TObject);
private
FObservers : TList<IPsViewModel>;
FMainViewModel : IPsMainViewModel;
FCommandRecord : TPsCommandRecord;
protected
procedure Notify;
….
end;
In my test project I have a descendent class
TTestabledmMariaDBConnection = class(TdmMariaDBConnection)
end;
var
CUT : TTestabledmMariaDBConnection;
procedure TTestModel_MariaDBConnection.Setup;
begin
CUT := TTestabledmMariaDBConnection.Create(nil);
end;
so I can call protected methods. What I have so far that doesn't work because I cannot provide the private record instance from TdmMariaDBConnection, and just focusing on the MainViewModel for now.
procedure TTestModel_MariaDBConnection.NotifyCallsMainViewModelHandleCommands;
var
MVMMock : TMock<IPsMainViewModel>;
LCommandRecord : TPsCommandRecord;
begin
//Arrange
MVMMock := TMock<IPsMainViewModel>.Create;
MVMMock.Setup.Expect.Once.When.HandleCommands(LCommandRecord);
//Act
CUT.Attach(MVMMock);
CUT.Notify;
//Assert
try
MVMMock.Verify();
Assert.Pass();
except on E: EMockException do
Assert.Fail(E.Message);
end;
end;
Obviously the addition of LCommandRecord are wrong I just added them to get it to compile. I need(I think) the record instance from The test class in the setup. I tried adding a function to get that but it didn't work either.
function TdmMariaDBConnection.GetCommandRecord: TPsCommandRecord;
begin
Result := FCommandRecord;
end;
MVMMock.Setup.Expect.Once.When.HandleCommands(CUT.GetCommandRecord);
The test doesn't even complete, I get an incomplete circle in TestInsight GUI instead of the hoped for Green check.
Any help would be appreciated. Also is this the right use of Verify? I can only find the explanation that it does nothing when passing, so how to add an Assert?
Thanks in advance
Gary
The way you setup the mock it will be very strict about the parameters being passed and checks for equality to the specified setup when calling Verify.
There is also a long standing issue in Delphi Mocks that record parameters are not properly compared for equality (they only equal if the parameters where the exact same address - see SameValue in Delphi.Mocks.Helpers.pas - I know of this issue because it is my code being used with my permission - I wrote a better version some while ago being used in Spring4D which also has mocking fwiw). This is why even if it would not run in a circle with your added GetCommandRecord it might not pass.
What I usually suggest people to do (I wrote 2 mocking libraries for Delphi so far) when using mocks is to be as permissive as possible. Fortunately Delphi Mocks supports parameter matcher that let you specify that actually you don't care that much for the exact value of the parameter being passed.
That being said simply change your setup to call
MVMMock.Setup.Expect.Once.When.HandleCommands(It0.IsAny<TPsCommandRecord>);
That tells the internal matcher recording calls to the mock from the SUT that it does not matter what value comes in which satisfies the expectation.
By the way for a similar reason as with the SameValue bug it will not work using It0.IsEqualTo(LCommandRecord) because the used comparer for records internally calls System.Generics.Defaults.Equals_Binary which just does a flat memory compare of the record which possibly fails for any reference type.
I'm trying to convert my aplliction from Delphi XE8 to 10.2 Tokyo. I'm getting strange runtime exeptions with casting objects provided by interfafce acrocss packages ( bpl's). when I try to cast objects with "as" keyword I'm getting
this exception during runtime:
Project Project1.exe raised exception class EInvalidCast with message
'Invalid class typecast'
Here is the code :
Interface in a separte package Plugin_interface.bpl :
unit MainIntf;
interface
Type IMainInft = interface
['{FE08C4A2-069C-4B8C-BB1B-445348CAB6A0}']
function GetForm : TObject;
end;
implementation
end.
Interface implamentation provided in Project1.exe :
unit MainImpl;
interface
uses MainIntf;
Type TMain = class(TInterfacedObject,IInterface,IMainInft)
function GetForm : TObject;
end;
implementation
uses unit1;
function TMain.GetForm: TObject ;
begin
result:=Form1; // interafce is implemented on the main form so Form1 is rechable form here
end;
end.
And finally in another package "plugin.bpl" I'm trying to obtain object from interface :
unit Plugin_main;
interface
uses Mainintf, Vcl.Forms;
type TPlugin = class (Tobject)
IIMyRefernceToMianIntf: IMainInft;
end;
function RegisterPlugin(AMainIntf: IMainInft): TForm ; export;
procedure UnRegisterPlugin; export;
exports
RegisterPlugin,
UnRegisterPlugin;
var
Plugin_obj: TPlugin;
implementation
uses vcl.Dialogs,System.Classes ;
function RegisterPlugin(AMainIntf: IMainInft): TForm ;
var
MyForm : TForm ;
begin
Plugin_obj:=TPlugin.Create;
Plugin_obj.IIMyRefernceToMianIntf:=AMainIntf;
if AMainIntf.GetForm is TForm then
Showmessage ('Great it is a Tform') // will not happen
else
Showmessage ('Sorry it is not Tform'); // will happen
if TComponent (AMainIntf.GetForm).Classname='TForm1' then
Showmessage ('What ?? It is TForm1 decsendant from TForm so is it TForm after all ?!'); // will happen
// result:= AMainIntf.GetForm as TForm -- This will rise na exception
result:= TForm( AMainIntf.GetForm) ; // this will work
end;
procedure UnRegisterPlugin;
begin
Plugin_obj.Free;
end;
end.
Why cant I use "as" and "is" keyword .
Only hard catsing will do, but i hate to do it .
on XE8 compiler everything worked as expected - problem exists on XE 10.2 tokyo compiler
The "is" keyword checks the actual objects to see it is of the type you are asking. So, checking for this:
if AMainIntf.GetForm is TForm then
Showmessage ('Great it is a Tform') // will not happen
does not happen because GetForm returns TObject and not TForm. Checking with "is" means, also, that you are checking for castability, i.e. the ability to use the "as" keyword. Since, the "is" check fails, that command fails as well:
result:= AMainIntf.GetForm as TForm;
Your next option here is to hard-cast GetForm the way you do it:
TForm(AMainIntf.GetForm);
which works because this casting does not check whether GetForm is of TForm type. Since you return a form in TMain, this hard-casting is safe bet for you.
Having said that, however, why don't you return TForm directly rather than TObject? Do you use IMainInft in other classes that return other types than TForm?
In Delphi I have the following code, and all works well:
var
StackOptions:TStack<String>;
s:string;
bfisio:boolean;
begin
StackOptions:=TStack<String>.Create;
//some pushs here
for s in StackOptions do begin
dosomething;
end;
end;
In Lazarus I can do this:
uses
..., gstack;
type
TStringStack = specialize TStack<String>;
var
StackOptions: TStringStack;
s:string;
begin
//But this code doesn;t compile
StackOptions := TStringStack.Create;
//some pushs here
for s in StackOptions do begin // <-- Error
dosomething;
end;
end;
I get the next error in Lazarus:
Compile Project, Target: TicketLaz.exe: Exit code 1, Errors: 1
umain.pas(263,12) Error: Cannot find an enumerator for the type "TStack$1$crcAC3AF268"
How could I loop the Stack and search for a value with Lazarus without removing items from Stack?
FPC's stack is backed by a TVector.
The TVector has an enumerator.
You can easily add a class helper like so:
Quick and dirty code.
type
TStringStack = specialize TStack<String>;
type
{ TStackHelper }
TVectorEnumerator = specialize TVector<string>.TVectorEnumerator;
TStackHelper = class helper for TStringStack
function GetEnumerator: TVectorEnumerator;
end;
{ TStackHelper }
function TStackHelper.GetEnumerator: TVectorEnumerator;
begin
Result:= FData.GetEnumerator;
end;
I really don't see why a stack is not supposed to have an iterator.
Even in assembly you can simply do mov reg,[esp-04].
This puritanical approach to data-structures helps no-one
All this is complicated by the fact that TStack is generic.
I know FPC allows generic class helpers, but I'm not sure how to make the solution work for all TStack<T>
Another approach would be to simply edit gstack.pas to expose the iterator.
Like many other Firemonkey developers, I need a general multi-platform solution to send messages from a thread to the main thread (to replace PostMessage). I need it to also work on iOS.
There is a solution by François Piette that is implemented for Android and Windows, but not for iOS:
TMessagingSystem.
However, I think it can be done much more simple by using the "new" TMessageManager in combination with TThread.Queue(). But no one have published code, using this aproach, that actually works (e.g. this one is not complete).
Do you have a tested implementation you would like to share with the community (or maybe just suggestions how to implement it right)?
Ok, here is my implementation. I did not use TMessagingSystem as it seems to just add complexity (for my situation at least). It works so far, but if anyone have suggestions for improvements, I will be happy to improve it.
I looked at the solution by Uwe Raabe but I wanted to make it more straightforward and easy to implement in the large codebase that I am converting to FMX.
With the solution below I can simply replace all PostMessage() with gMessageHandler.PostMessage (removing the win handle argument), and add the message functions in the form to tMainForm.MessageCallBack.
I created a small unit that I can include everywhere I need the PostMessage function. Those places does not need to know about the form:
unit MessageHandler
interface
tAllOSMessage = procedure(aMessageID, aData1, aData2: integer) of object;
tAllOSMessageHandler = class
private
fOnMessage : tAllOSMessage;
public
constructor Create(aMessageCallBack: tAllOSMessage);
procedure PostMessage(aMessageID, aData1, aData2: integer; aSourceThread: TThread = nil);
end;
var
gMessageHandler: tAllOSMessageHandler;
implementation
constructor tAllOSMessageHandler.Create(aMessageCallBack: tAllOSMessage);
begin
fOnMessage := aMessageCallBack;
end;
procedure tAllOSMessageHandler.PostMessage(aMessageID, aData1, aData2: integer; aSourceThread: TThread);
begin
if aSourceThread=nil then
aSourceThread := TThread.CurrentThread;
aSourceThread.Queue(nil, procedure
begin
if Assigned(fOnMessage) then
fOnMessage(aMessageID, aData1, aData2);
end );
end;
end.
Then I add these lines to the main form unit:
//Added to main form:
tMainForm = class(TForm)
...
procedure MessageCallBack(aMessageID, aData1, aData2: integer);
//Added to MainFormCreate
gMessageHandler := tAllOSMessageHandler.Create(MessageCallBack);
//Added to MainFormDestroy
FreeAndNil(gMessageHandler)
procedure tMainForm.MessageCallBack(aMessageID, aData1, aData2: integer);
begin
case aMessageID of
MyMessage1 : MyFunction1(aData1,aData2);
...
end;
end;
I tried my hand at a generic class, and on a second attempt I've tried to make a generic locked pool. I almost got it to work
I stumble on the spot where I want to put a generic typed class into a locked tlist obtained from tthreadlist.
The main question is:
Does anybody know a solution to this problem? (see "problem spot" in the source)
Hints, minor questions:
Do I need an additional constraint that signals reference? (I tried adding ,reference to the already existing class and constructor)
Does sb know a good overview page of all "special" generic constraints (class,constructor) . Couldn't find much in the manual.
the company is at D2009, but I've a single license DXE for migration preparation purposes.
The objects used by this pool are tobject, and worse, some of them have some crucial methods that must be inlined. (it is an image processing app, which is also why I'm not that concerned with relative simply locks. Granularity is coarse). I mention this, since it might make interface based solutions difficult.
type
TLockedPool<T:class,constructor> = class
private
lst : tthreadlist;
public
type sometype =t; // part of workarounds.
destructor destroy;
constructor create;
function getitem:T;
procedure putitem(var b:T);
end;
constructor TLockedPool<T>.create;
begin
lst:=TThreadlist.Create;
end;
destructor TLockedPool<T>.destroy;
var i : integer;
v: tlist;
begin
v:=lst.locklist;
for i:=0 to v.count-1 do
Tobject(v[i]).Free;
lst.unlocklist;
v.clear;
freeandnil(lst);
inherited;
end;
function TLockedPool<T>.getitem: T;
var cnt:integer;
v : tlist;
begin
v:=lst.LockList;
cnt:=v.Count;
if cnt>0 then
begin
result:=tobject(v[cnt-1]);
v.delete(cnt-1);
end
else
begin
result:=T.create;
end;
lst.UnlockList;
end;
procedure TLockedPool<T>.putitem(var b: T);
var v : Tlist;
x : sometype;
begin
if assigned(b) then // some older parts of the framework are dirty and try to put in NILs.
begin
v:=lst.LockList;
x:=b;
v.Add(pointer(sometype(x))); // <--- the problemspot
lst.unlocklist;
end;
b:=nil;
end;
Use v.Add(TObject(x)) or, if you must (it may not work in 2009, awkward for me to check), v.Add(PPointer(#x)^).