I am trying to call methods by name in a firemonkey project. But so far no luck.
Below is my code:
type
TExecute = procedure of object;
TUpdates= class(TDataModule)
procedure UpdateToVersion(Version: Integer);
private
procedure UpdateToVersion1;
procedure UpdateToVersion2;
procedure UpdateToVersion3;
procedure Call(Name: string);
public
end;
procedure TUpdates.Call(Name: String);
var
m:TMethod;
Exe:TExecute;
begin
m.Data := pointer(Self);
m.Code := Self.MethodAddress(Name);
Exe := TExecute(m);
Exe;
end;
procedure TUpdates.UpdateToVersion(Version: Integer);
begin
Call('UpdateToVersion'+version.ToString);
end;
procedure TUpdates.UpdateToVersion1;
begin
//code
end;
procedure TUpdates.UpdateToVersion2;
begin
//code
end;
procedure TUpdates.UpdateToVersion3;
begin
//code
end;
Results:
When I call for example UpdateToVersion(1) I get an access violation and procedure UpdateToVersion1 doesn't get called.
I got this code from an example from the link below:
http://www.swissdelphicenter.ch/torry/showcode.php?id=799
MethodAddress requires that the method is published, as is the method in the example code. Your methods are private. Hence MethodAddress fails and returns nil.
Solve the problem by publishing the methods.
If you wish to perform this sort of task with non-published methods then you will need to use enhanced RTTI.
Related
I'm getting access violation when calling the Edit method of TComponentEditor class:
type
TLBIWXDataGridEditor = class(TComponentEditor)
public
function GetVerbCount: Integer; override;
function GetVerb(Index: Integer): string; override;
procedure ExecuteVerb(Index: Integer); override;
procedure Edit; override;
end;
Here is the overridden Edit Method:
procedure TLBIWXDataGridEditor.Edit;
var
_DsgForm: TLBIWXDataGridDesigner;
begin
_DsgForm := TLBIWXDataGridDesigner(Application);
try
_DsgForm.DataGrid := TLBIWXDataGrid(Self.Component);
_DsgForm.ShowModal;
finally
FreeAndNil(_DsgForm);
end;
end;
All TLBIWXDataGrid properties will be changeable only inside the design form, because it doesn't have any published properties.
When calling the Edit method by double clicking the component at design time I either get AV or the IDE Crashes abruptly.
I don't think the problem is related to the other overridden methods, but here are their implementations:
procedure TLBIWXDataGridEditor.ExecuteVerb(Index: Integer);
begin
case Index of
0: MessageDlg ('add info here', mtInformation, [mbOK], 0);
1: Self.Edit;
end;
end;
function TLBIWXDataGridEditor.GetVerb(Index: Integer): string;
begin
case Index of
0: Result := '&About...';
1: Result := '&Edit...';
end;
end;
function TLBIWXDataGridEditor.GetVerbCount: Integer;
begin
result := 2;
end;
What am I missing?
This line is wrong:
_DsgForm := TLBIWXDataGridDesigner(Application);
It is typecasting the Application object into a TLBIWXDataGridDesigner, which will not work.
Use this instead:
_DsgForm := TLBIWXDataGridDesigner.Create(Application);
Or this, since you are freeing the dialog manually, so it does not need an Owner assigned:
_DsgForm := TLBIWXDataGridDesigner.Create(nil);
I have a code (Singleton- Pattern) which works with Delphi RAD 10.1
type
TSharedData = class
private
FPOL: integer;
class var FUniqueInstance: TSharedData;
procedure SetFPol(const Value: integer);
constructor Create;
public
class function GetInstance: TSharedData;
property POL: integer read FPOL write SetFPol;
end;
var
Key: TObject;
implementation
{ TSharedData }
constructor TSharedData.Create;
begin
SetFPol(1);
end;
class function TSharedData.GetInstance: TSharedData;
begin
TMonitor.Enter(Key); // <-- error here
try
if FUniqueInstance = nil then
begin
FUniqueInstance := TSharedData.Create;
end;
finally
TMonitor.Exit(Key);
end;
Result := FUniqueInstance;
end;
procedure TSharedData.SetFPol(const Value: integer);
begin
FPOL := Value;
end;
initialization
Key:= TObject.Create;
finalization
Key.Free;
I need now the same code in Delphi 7. But the compiler said, "TMonitor isn't known".
Where can I find TMonitor or how can I replace it with an alternative function?
I thank you in advance for any information.
You can use TCriticalSection from SyncObjs unit.
The approach changes just a little bit. The critical section should be used as an object. So if you want to protect an area of you object on can do something like:
type
TSafeCounter = class(TObject)
private
FValue: Integer;
FCriticalSection: TCriticalSection;
public
constructor Create;
destructor Destroy; override;
procedure SafeInc;
procedure SafeDec;
function CurValue: Integer;
end;
implementation
{ TSafeCounter }
constructor TSafeCounter.Create;
begin
FCriticalSection := TCriticalSection.Create;
end;
function TSafeCounter.CurValue: Integer;
begin
FCriticalSection.Acquire;
try
Result := FValue;
finally
FCriticalSection.Release;
end;
end;
procedure TSafeCounter.SafeDec;
begin
FCriticalSection.Acquire;
try
Dec(FValue);
finally
FCriticalSection.Release;
end;
end;
destructor TSafeCounter.Destroy;
begin
FCriticalSection.Free;
inherited;
end;
procedure TSafeCounter.SafeInc;
begin
FCriticalSection.Acquire;
try
Inc(FValue);
finally
FCriticalSection.Release;
end;
end;
If you are facing very extreme scenario (performance), you can work another kinds of implementations of critical sections, but them will also increase the complexity of working with it like the read/write critical section.
In Delphi 6, I could change the Mouse Cursor for all forms using Screen.Cursor:
procedure TForm1.Button1Click(Sender: TObject);
begin
Screen.Cursor := crHourglass;
end;
I am searching the equivalent in Firemonkey.
Following function does not work:
procedure SetCursor(ACursor: TCursor);
var
CS: IFMXCursorService;
begin
if TPlatformServices.Current.SupportsPlatformService(IFMXCursorService) then
begin
CS := TPlatformServices.Current.GetPlatformService(IFMXCursorService) as IFMXCursorService;
end;
if Assigned(CS) then
begin
CS.SetCursor(ACursor);
end;
end;
When I insert a Sleep(2000); at the end of the procedure, I can see the cursor for 2 seconds. But the Interface probably gets freed and therefore, the cursor gets automatically resetted at the end of the procedure. I also tried to define CS as a global variable, and add CS._AddRef at the end of the procedure to prevent the Interface to be freed. But it did not help either.
Following code does work, but will only work for the main form:
procedure TForm1.Button1Click(Sender: TObject);
begin
Application.MainForm.Cursor := crHourGlass;
end;
Since I want to change the cursor for all forms, I would need to iterate through all forms, but then the rollback to the previous cursors is tricky, as I need to know the previous cursor for every form.
My intention:
procedure TForm1.Button1Click(Sender: TObject);
var
prevCursor: TCursor;
begin
prevCursor := GetCursor;
SetCursor(crHourglass); // for all forms
try
Work;
finally
SetCursor(prevCursor);
end;
end;
You'd have to implement your own cursor service that makes it possible to enforce a certain cursor.
unit Unit2;
interface
uses
FMX.Platform, FMX.Types, System.UITypes;
type
TWinCursorService = class(TInterfacedObject, IFMXCursorService)
private
class var FPreviousPlatformService: IFMXCursorService;
class var FWinCursorService: TWinCursorService;
class var FCursorOverride: TCursor;
class procedure SetCursorOverride(const Value: TCursor); static;
public
class property CursorOverride: TCursor read FCursorOverride write SetCursorOverride;
class constructor Create;
procedure SetCursor(const ACursor: TCursor);
function GetCursor: TCursor;
end;
implementation
{ TWinCursorService }
class constructor TWinCursorService.Create;
begin
FWinCursorService := TWinCursorService.Create;
FPreviousPlatformService := TPlatformServices.Current.GetPlatformservice(IFMXCursorService) as IFMXCursorService; // TODO: if not assigned
TPlatformServices.Current.RemovePlatformService(IFMXCursorService);
TPlatformServices.Current.AddPlatformService(IFMXCursorService, FWinCursorService);
end;
function TWinCursorService.GetCursor: TCursor;
begin
result := FPreviousPlatformService.GetCursor;
end;
procedure TWinCursorService.SetCursor(const ACursor: TCursor);
begin
if FCursorOverride = crDefault then
begin
FPreviousPlatformService.SetCursor(ACursor);
end
else
begin
FPreviousPlatformService.SetCursor(FCursorOverride);
end;
end;
class procedure TWinCursorService.SetCursorOverride(const Value: TCursor);
begin
FCursorOverride := Value;
TWinCursorService.FPreviousPlatformService.SetCursor(FCursorOverride);
end;
end.
MainUnit:
procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
begin
TWinCursorService.CursorOverride := crHourGlass;
try
Sleep(2000);
finally
TWinCursorService.CursorOverride := crDefault;
end;
end;
The IFMXCursorService is how the FMX framework manages cursors. It is not intended for your use. The mechanism that you are meant to use is the form's Cursor property.
This means that you will need to remember the cursor for each form in order to restore it. I suggest that you use a dictionary to do that. Wrap the functionality up into a small class and then at least the pain is localized to the implementation of that class. You can make the code at the call site reasonable.
Further to this post whose accepted answer remains very cryptic:
#Button1.OnClick := pPointer(Cardinal(pPointer( procedure (sender: tObject) begin ((sender as TButton).Owner as TForm).Caption := 'Freedom to anonymous methods!' end )^ ) + $0C)^;
I wonder wether it is possible to devise a simplest and elegant way akin to:
Button.OnClick :=
AnonProc2NotifyEvent (
procedure (Sender: TObject)
begin
((Sender as TButton).Owner as TForm).Caption := 'Freedom to anonymous methods!'
end
);
so as to attain the same purpose and where AnonProc2NotifyEvent is a method of the owner of Button with the following signature:
TOwnerOfButton = class(TForm)
Button: TButton;
...
private
...
protected
function AnonProc2NotifyEvent(aProc: TProc<TObject>): TNotifyEvent;
public
...
end;
Is that feasible and if so how to implement it ?
This will do the job readily enough:
type
TNotifyEventWrapper = class(TComponent)
private
FProc: TProc<TObject>;
public
constructor Create(Owner: TComponent; Proc: TProc<TObject>);
published
procedure Event(Sender: TObject);
end;
constructor TNotifyEventWrapper.Create(Owner: TComponent; Proc: TProc<TObject>);
begin
inherited Create(Owner);
FProc := Proc;
end;
procedure TNotifyEventWrapper.Event(Sender: TObject);
begin
FProc(Sender);
end;
function AnonProc2NotifyEvent(Owner: TComponent; Proc: TProc<TObject>): TNotifyEvent;
begin
Result := TNotifyEventWrapper.Create(Owner, Proc).Event;
end;
The Owner parameter in AnonProc2NotifyEvent is so that the lifetime of the wrapper object can be managed. Without something like that you would leak instances of TNotifyEventWrapper.
Pass as Owner, the component to which you are connecting the event. For example:
Button1.OnClick := AnonProc2NotifyEvent(
Button1,
procedure(Sender: TObject)
begin
(Sender as TButton).Caption := 'Clicked';
end
);
So, when the button is destroyed, the TNotifyEventWrapper will also be destroyed. The wrapper object must live at least as long as the object to whose events it is associated. And so the choice of Button1 as the owner is the natural and obvious one.
For reference this what I am getting at, I studied Barry Kelly's blog post referenced in the prior SO post mentioned above and came up with this solution:
function TMainForm.Proc2NotifyEvent(const aProc: TNotifyReference): TNotifyEvent;
type
TVtable = array[0..3] of Pointer;
PVtable = ^TVtable;
PPVtable = ^PVtable;
begin
TMethod(Result).Code := PPVtable((#aProc)^)^^[3];
TMethod(Result).Data := Pointer((#aProc)^);
end;
Still cryptic but encapsuled, so easing the task of the coder compared to the initial method.
I tried to tidy MethRefToMethPtr and MakeNotify and put it all in one method.
Notice that there was (a slight) change in the method's signature, the argument aProc became const.
Passing a method as an argument is not a problem:
type
TSomething = class
Msg: string;
procedure Show;
end;
procedure TSomething.Show;
begin
ShowMessage(Msg);
end;
type TProc = procedure of object;
procedure Test(Proc: TProc);
begin
Proc;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Smth: TSomething;
begin
Smth:= TSomething.Create;
Smth.Msg:= 'Hello';
Test(Smth.Show);
end;
I need something tricky - to pass only a code part of a method. I know I can do it:
procedure Test2(Code: Pointer);
var
Smth: TSomething;
Meth: TMethod;
begin
Smth:= TSomething.Create;
Smth.Msg:= 'Hello Hack';
Meth.Data:= Smth;
Meth.Code:= Code;
TProc(Meth);
Smth.Free;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Test2(#TSomething.Show);
end;
but that is a hack and unsafe - the compiler can't check the method's arguments.
The question: Is it possible to do the same in a typesafe way?
I got it finally. With type checking and no need to declare variable for the calling event!
type
TSomething = class
Msg: string;
procedure Show;
procedure ShowWithHeader(Header : String);
end;
TProc = procedure of object;
TStringMethod = procedure(S : String) of Object;
procedure TSomething.Show;
begin
ShowMessage(Msg);
end;
procedure TSomething.ShowWithHeader(Header: String);
begin
ShowMessage(Header + ' : ' + Msg);
end;
procedure Test2(Code: TProc);
var
Smth: TSomething;
begin
Smth:= TSomething.Create;
Smth.Msg:= 'Hello Hack 2';
TMethod(Code).Data := Smth;
Code;
Smth.Free;
end;
procedure Test3(Code: TStringMethod; S : String);
var
Smth: TSomething;
begin
Smth:= TSomething.Create;
Smth.Msg:= 'Hello Hack 3';
TMethod(Code).Data := Smth;
Code(S);
Smth.Free;
end;
procedure TForm4.btn1Click(Sender: TObject);
begin
Test2(TSomething(nil).Show);
// Test2(TSomething(nil).ShowWithHeader); // Cannot Compile
end;
procedure TForm4.btn2Click(Sender: TObject);
begin
// Test3(TSomething(nil).Show,'Hack Header'); // Cannot Compile
Test3(TSomething(nil).ShowWithHeader,'Hack Header');
end;
I finally adopted a workaround based on stub functions. It does not answer my original question, contains a stub overhead but solves my problem with duplicated code and free from hackish code:
type
TSmth = class
procedure Method1;
procedure Method2;
end;
type
TDoMethod = procedure(Instance: TSmth);
procedure DoMethod1(Instance: TSmth);
begin
Instance.Method1;
end;
procedure DoMethod2(Instance: TSmth);
begin
Instance.Method2;
end;
procedure TestMethod(DoMethod: TDoMethod);
var
Smth: TSmth;
begin
Smth:= TSmth.Create;
{ a lot of common setup code here }
DoMethod(Smth);
{ a lot of common check code here }
Smth.Free;
end;
procedure TestMethod1;
begin
TestMethod(DoMethod1);
end;
procedure TestMethod2;
begin
TestMethod(DoMethod2);
end;
Disclaimer: I personally would never use this code and could never recommend or condone its use.
Do it like this:
procedure Test2(Method: TProc);
var
Smth: TSomething;
begin
Smth:= TSomething.Create;
Smth.Msg:= 'Hello Hack';
TMethod(Method).Data:= Smth;
Method();
end;
Of course this is still unsafe since it will only work if what you put into Data is in fact compatible with the method.
Serg asks:
How will you call your Test2 without creating a dummy instance of TSomething?
I suppose you can do it like this, for static (i.e. non-virtual and non-dynamic) methods:
var
Obj: TSomething;
....
Test2(Obj.Show);//no need to actually create Obj
Of course all this illustrates what a grotesque hack this is. I think this is no better than the version in your question. There's no real clean way to do what you ask.
I suspect that the correct way to solve your real problem would be to use RTTI to call the method.
This is an example using anonymous methods.
No code duplication and typesafe method calls.
type
TSmth = class
procedure Method1;
procedure Method2;
end;
procedure Test;
type
TMyMethodRef = reference to procedure;
PMyTestRef = reference to procedure(aMethod :TMyMethodRef);
var
TestP : PMyTestRef;
Smth : TSmth;
begin
TestP :=
procedure( aMethod : TMyMethodRef)
begin
Smth := TSmth.Create;
try
// setup Smth
aMethod;
// test Smth
finally
Smth.Free;
end;
end;
TestP(Smth.Method1); // Test Method1
TestP(Smth.Method2); // Test Method2
end;