Can I use a closure on an event handler (ie, TButton OnClick) - delphi

If I try to use a closure on an event handler the compiler complains with :
Incompatible types: "method pointer and regular procedure"
which I understand.. but is there a way to use a clouser on method pointers? and how to define if can?
eg :
Button1.Onclick = procedure( sender : tobject ) begin ... end;
Thanks!

#Button1.OnClick := pPointer(Cardinal(pPointer( procedure (sender: tObject)
begin
((sender as TButton).Owner as TForm).Caption := 'Freedom to anonymous methods!'
end )^ ) + $0C)^;
works in Delphi 2010

An excellent question.
As far as I know, it's not possible to do in current version of Delphi. This is much unfortunate since those anonymous procedures would be great to have for quickly setting up an object's event handlers, for example when setting up test fixtures in a xUnit kind of automatic testing framework.
There should be two ways for CodeGear to implement this feature:
1: Allow for creation of anonymous methods. Something like this:
Button1.OnClick := procedure( sender : tobject ) of object begin
...
end;
The problem here is what to put as the self pointer for the anonymous method. One might use the self pointer of the object from which the anonymous method was created, but then one can only create anonymous methods from an object context. A better idea might be to simply create a dummy object behind the scenes to contain the anonymous method.
2: Alternatively, one could allow Event types to accept both methods and procedures, as long as they share the defined signature. In that way you could create the event handler the way you want:
Button1.OnClick := procedure( sender : tobject ) begin
...
end;
In my eyes this is the best solution.

In previous Delphi versions you could use a regular procedure as event handler by adding the hidden self pointer to the parameters and hard typecast it:
procedure MyFakeMethod(_self: pointer; _Sender: TObject);
begin
// do not access _self here! It is not valid
...
end;
...
var
Meth: TMethod;
begin
Meth.Data := nil;
Meth.Code := #MyFakeMethod;
Button1.OnClick := TNotifyEvent(Meth);
end;
I am not sure the above really compiles but it should give you the general idea. I have done this previously and it worked for regular procedures. Since I don't know what code the compiler generates for closures, I cannot say whether this will work for them.

Its easy to extend the below to handle more form event types.
Usage
procedure TForm36.Button2Click(Sender: TObject);
var
Win: TForm;
begin
Win:= TForm.Create(Self);
Win.OnClick:= TEventComponent.NotifyEvent(Win, procedure begin ShowMessage('Hello'); Win.Free; end);
Win.Show;
end;
Code
unit AnonEvents;
interface
uses
SysUtils, Classes;
type
TEventComponent = class(TComponent)
protected
FAnon: TProc;
procedure Notify(Sender: TObject);
class function MakeComponent(const AOwner: TComponent; const AProc: TProc): TEventComponent;
public
class function NotifyEvent(const AOwner: TComponent; const AProc: TProc): TNotifyEvent;
end;
implementation
{ TEventComponent }
class function TEventComponent.MakeComponent(const AOwner: TComponent;
const AProc: TProc): TEventComponent;
begin
Result:= TEventComponent.Create(AOwner);
Result.FAnon:= AProc;
end;
procedure TEventComponent.Notify(Sender: TObject);
begin
FAnon();
end;
class function TEventComponent.NotifyEvent(const AOwner: TComponent;
const AProc: TProc): TNotifyEvent;
begin
Result:= MakeComponent(AOwner, AProc).Notify;
end;
end.

Related

Creating an interface implementer instance at runtime

First, a little explanation about my situation:
I have a sample interface which is implemented by different classes, and these classes might not always have a shared ancestor:
IMyInterface = interface
['{1BD8F7E3-2C8B-4138-841B-28686708DA4D}']
procedure DoSomething;
end;
TMyImpl = class(TInterfacedPersistent, IMyInterface)
procedure DoSomething;
end;
TMyImp2 = class(TInterfacedObject, IMyInterface)
procedure DoSomething;
end;
I also have a factory method which is supposed to create an instance of an object which implements my interface. My factory method receives the class name as its parameter:
function GetImplementation(const AClassName: string): IMyInterface;
I tried two approaches to implement this factory method, the first one was using extended RTTI:
var
ctx : TRttiContext;
t : TRttiInstanceType;
begin
t := ctx.FindType(AClassName).AsInstance;
if Assigned(t) then
Result := t.GetMethod('Create').Invoke(t.MetaclassType, []).AsInterface as IMyInterface;
end;
In this approach I am calling the default constructor which is fine in my scenario. The problem with this is, at runtime, I get an error telling me the object does not support IMyInterface. What's more, the created object is not assigned to an interface variable; therefore, it will be leaked. I also tried returning the value using TValue.AsType method, but it gives me Access Violation:
function GetImplementation(const AClassName: string): IMyInterface;
var
ctx : TRttiContext;
rt : TRttiInstanceType;
V : TValue;
begin
rt := ctx.FindType(AClassName).AsInstance;
if Assigned(rt) then
begin
V := rt.GetMethod('Create').Invoke(rt.MetaclassType, []);
Result := V.AsType<IMyInterface>;
end;
end;
.
The second approach I tried was using a generic dictionary to hold pairs of , and provide registration, unregistration methods:
TRepository = class
private
FDictionary : TDictionary<string, TClass>;
public
constructor Create;
destructor Destroy; override;
function GetImplementation(const AClassName: string): IMyInterface;
procedure RegisterClass(AClass: TClass);
procedure UnregisterClass(AClass: TClass);
end;
Here I implemented GetImplementation method as this:
function TRepository.GetImplementation(const AClassName: string): IMyInterface;
var
Obj : TObject;
begin
if FDictionary.ContainsKey(AClassName) then
begin
Obj := FDictionary[AClassName].Create;
Obj.GetInterface(IMyInterface, Result);
end;
end;
This works fine, and I can call DoSomething method using the returned value of GetImplementation, but it still has the memory-leak problem; Obj which is created here is not assigned to any interface variable; therefore, it is not reference-counted, and is leaked.
.
Now, my actual question:
So my question is, how can I safely create an instance of a class which implements my interface at runtime? I saw Delphi Spring Framework, and it provides such functionality in its Spring.Services unit, but it has its own reflection routines and lifetime management models. I am looking for a lightweight solution, not a whole 3rd-party framework to do this for me.
Regards
The first case using the RTTI give you a access violation because the TRttiContext.FindType(AClassName) cannot find the Rtti info for the classes which are not registered or used explicity in the app.
So you can change your code to
function GetImplementation(AClass: TClass): IMyInterface;
var
ctx : TRttiContext;
t : TRttiInstanceType;
begin
t := ctx.GetType(AClass).AsInstance;
if Assigned(t) then
Result := t.GetMethod('Create').Invoke(t.MetaclassType, []).AsInterface As IMyInterface;
end;
and call in this way
AClass:=GetImplementation(TMyImp2);
Now if you want to use the Class name to invoke the class, using a list (like your TRepository class) to register the classes is a valid aproach. about the memory leak i'm pretty sure which is caused because the TMyImpl class is derived from the TInterfacedPersistent which not implement reference counting directly like the TInterfacedObject.
This implementation of the the TRepository must works ok.
constructor TRepository.Create;
begin
FDictionary:=TDictionary<string,TClass>.Create;
end;
destructor TRepository.Destroy;
begin
FDictionary.Free;
inherited;
end;
function TRepository.GetImplementation(const AClassName: string): IMyInterface;
var
Obj : TObject;
begin
if FDictionary.ContainsKey(AClassName) then
begin
Obj := FDictionary[AClassName].Create;
Obj.GetInterface(IMyInterface, Result);
end;
end;
{
or using the RTTI
var
ctx : TRttiContext;
t : TRttiInstanceType;
begin
t := ctx.GetType(FDictionary[AClassName]).AsInstance;
if Assigned(t) then
Result := t.GetMethod('Create').Invoke(t.MetaclassType, []).AsInterface As IMyInterface;
end;
}
procedure TRepository.RegisterClass(AClass: TClass);
begin
FDictionary.Add(AClass.ClassName,AClass);
end;
procedure TRepository.UnregisterClass(AClass: TClass);
begin
FDictionary.Remove(AClass.ClassName);
end;
I think I would opt for the second option, mainly because I prefer to avoid RTTI unless it is the only possible solution to a problem.
But in both your proposed options you state that
the object which is created here is not assigned to any interface variable
That's simply not true. In both cases you assign to Result which has type IMyInterface. If you have a memory leak, it is caused by some other code, not by this code.
And #RRUZ has found the cause of the leak – namely using TInterfacedPersistent which does not implement reference counted lifetime management. Your code won't leak for TInterfacedObject.
For what it is worth, I would assign directly to the interface variable rather than via an object reference, but that is just a matter of stylistic preference.
if FDictionary.TryGetValue(AClassName, MyClass) then
Result := MyClass.Create as IMyInterface;
You can do it using extended RTTI and TObject's GetInterface method:
function GetImplementation(const AClassName: string): IMyInterface;
var
ctx: TRttiContext;
t : TRttiInstanceType;
obj: TObject;
begin
Result := nil;
t := ctx.FindType(AClassName).AsInstance;
if Assigned(t) then begin
obj := t.GetMethod('Create').Invoke(t.MetaclassType, []).AsObject;
obj.GetInterface(IMyInterface, Result)
end;
end;
It won't work if the object overrides QueryInterface to do custom processing, but both TInterfacedPersistent and TInterfacedObject rely on GetInterface.

Generics and Marshal / UnMarshal. What am I missing here? PART #2 :-)

Following up on my earlier question :
Generics and Marshal / UnMarshal. What am I missing here?
In "part #1" (the link above) TOndrej provided a nice solution - that failed on XE2.
Here I provide corrected source to correct that.
And I feel the need to expand this issue a bit more.
So I would like to hear you all how to do this :
First - To get the source running on XE2 and XE2 update 1 make these changes :
Marshal.RegisterConverter(TTestObject,
function (Data: TObject): String // <-- String here
begin
Result := T(Data).Marshal.ToString; // <-- ToString here
end
);
Why ??
The only reason I can see must be related to XE2 is having a lot more RTTI information available. And hence it will try and marshal the TObject returned.
Am I on the right track here? Please feel free to comment.
More important - the example does not implement an UnMarshal method.
If anyone can produce one and post it here I would love it :-)
I hope that you still have interest in this subject.
Kind Regards
Bjarne
In addition to the answer to this question, I've posted a workaround to your previous question here: Generics and Marshal / UnMarshal. What am I missing here?
For some reason, using the non-default constructor of the TJsonobject causes the issue in XE2 - using the default constructor "fixed" the problem.
First, you need to move your TTestobject to its own unit - otherwise, RTTI won't be able to find/create your object when trying to unmarshal.
unit uTestObject;
interface
uses
SysUtils, Classes, Contnrs, Generics.Defaults, Generics.Collections, DbxJson, DbxJsonReflect;
type
{$RTTI EXPLICIT METHODS([]) PROPERTIES([vcPublished]) FIELDS([vcPrivate])}
TTestObject=class(TObject)
private
aList:TStringList;
public
constructor Create; overload;
constructor Create(list: array of string); overload;
constructor Create(list:TStringList); overload;
destructor Destroy; override;
function Marshal:TJSonObject;
class function Unmarshal(value: TJSONObject): TTestObject;
published
property List: TStringList read aList write aList;
end;
implementation
{ TTestObject }
constructor TTestObject.Create;
begin
inherited Create;
aList:=TStringList.Create;
end;
constructor TTestObject.Create(list: array of string);
var
I:Integer;
begin
Create;
for I:=low(list) to high(list) do
begin
aList.Add(list[I]);
end;
end;
constructor TTestObject.Create(list:TStringList);
begin
Create;
aList.Assign(list);
end;
destructor TTestObject.Destroy;
begin
aList.Free;
inherited;
end;
function TTestObject.Marshal:TJSonObject;
var
Mar:TJSONMarshal;
begin
Mar:=TJSONMarshal.Create();
try
Mar.RegisterConverter(TStringList,
function(Data:TObject):TListOfStrings
var
I, Count:Integer;
begin
Count:=TStringList(Data).Count;
SetLength(Result, Count);
for I:=0 to Count-1 do
Result[I]:=TStringList(Data)[I];
end);
Result:=Mar.Marshal(Self) as TJSonObject;
finally
Mar.Free;
end;
end;
class function TTestObject.Unmarshal(value: TJSONObject): TTestObject;
var
Mar: TJSONUnMarshal;
L: TStringList;
begin
Mar := TJSONUnMarshal.Create();
try
Mar.RegisterReverter(TStringList,
function(Data: TListOfStrings): TObject
var
I, Count: Integer;
begin
Count := Length(Data);
Result:=TStringList.Create;
for I := 0 to Count - 1 do
TStringList(Result).Add(string(Data[I]));
end
);
//UnMarshal will attempt to create a TTestObject from the TJSONObject data
//using RTTI lookup - for that to function, the type MUST be defined in a unit
Result:=Mar.UnMarshal(Value) as TTestObject;
finally
Mar.Free;
end;
end;
end.
Also note that the constructor has been overloaded - this allows you to see that the code is functional without pre-pouplating the data in the object during creation.
Here is the implementation for the generic class list object
unit uTestObjectList;
interface
uses
SysUtils, Classes, Contnrs, Generics.Defaults, Generics.Collections,
DbxJson, DbxJsonReflect, uTestObject;
type
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
TTestObjectList<T:TTestObject,constructor> = class(TObjectList<T>)
public
function Marshal: TJSonObject;
constructor Create;
class function Unmarshal(value: TJSONObject): TTestObjectList<T>; static;
end;
//Note: this MUST be present and initialized/finalized so that
//delphi will keep the RTTI information for the generic class available
//also, it MUST be "project global" - not "module global"
var
X:TTestObjectList<TTestObject>;
implementation
{ TTestObjectList<T> }
constructor TTestObjectList<T>.Create;
begin
inherited Create;
//removed the add for test data - it corrupts unmarshaling because the data is already present at creation
end;
function TTestObjectList<T>.Marshal: TJSonObject;
var
Marshal: TJsonMarshal;
begin
Marshal := TJSONMarshal.Create;
try
Marshal.RegisterConverter(TTestObjectList<T>,
function(Data: TObject): TListOfObjects
var
I: integer;
begin
SetLength(Result,TTestObjectlist<T>(Data).Count);
for I:=0 to TTestObjectlist<T>(Data).Count-1 do
Result[I]:=TTestObjectlist<T>(Data)[I];
end
);
Result := Marshal.Marshal(Self) as TJSONObject;
finally
Marshal.Free;
end;
end;
class function TTestObjectList<T>.Unmarshal(value: TJSONObject): TTestObjectList<T>;
var
Mar: TJSONUnMarshal;
L: TStringList;
begin
Mar := TJSONUnMarshal.Create();
try
Mar.RegisterReverter(TTestObjectList<T>,
function(Data: TListOfObjects): TObject
var
I, Count: Integer;
begin
Count := Length(Data);
Result:=TTestObjectList<T>.Create;
for I := 0 to Count - 1 do
TTestObjectList<T>(Result).Unmarshal(TJSONObject(Data[I]));
end
);
//UnMarshal will attempt to create a TTestObjectList<TTestObject> from the TJSONObject data
//using RTTI lookup - for that to function, the type MUST be defined in a unit,
//and, because it is generic, there must be a GLOBAL VARIABLE instantiated
//so that Delphi keeps the RTTI information avaialble
Result:=Mar.UnMarshal(Value) as TTestObjectList<T>;
finally
Mar.Free;
end;
end;
initialization
//force delphi RTTI into maintaining the Generic class information in memory
x:=TTestObjectList<TTestObject>.Create;
finalization
X.Free;
end.
There are several things that are important to note:
If a generic class is created at runtime, RTTI information is NOT kept unless there is a globally accessible object reference to that class in memory. See here: Delphi: RTTI and TObjectList<TObject>
So, the above unit creates such a variable and leaves it instantiated as discussed in the linked article.
The main procedure has been updated that shows both marshaling and unmarshaling the data for both objects:
procedure Main;
var
aTestobj,
bTestObj,
cTestObj : TTestObject;
aList,
bList : TTestObjectList<TTestObject>;
aJsonObject,
bJsonObject,
cJsonObject : TJsonObject;
s: string;
begin
aTestObj := TTestObject.Create(['one','two','three','four']);
aJsonObject := aTestObj.Marshal;
s:=aJsonObject.ToString;
Writeln(s);
bJsonObject:=TJsonObject.Create;
bJsonObject.Parse(BytesOf(s),0,length(s));
bTestObj:=TTestObject.Unmarshal(bJsonObject) as TTestObject;
writeln(bTestObj.List.Text);
writeln('TTestObject marshaling complete.');
readln;
aList := TTestObjectList<TTestObject>.Create;
aList.Add(TTestObject.Create(['one','two']));
aList.Add(TTestObject.Create(['three']));
aJsonObject := aList.Marshal;
s:=aJsonObject.ToString;
Writeln(s);
cJSonObject:=TJsonObject.Create;
cJSonObject.Parse(BytesOf(s),0,length(s));
bList:=TTestObjectList<TTestObject>.Unmarshal(cJSonObject) as TTestObjectList<TTestObject>;
for cTestObj in bList do
begin
writeln(cTestObj.List.Text);
end;
writeln('TTestObjectList<TTestObject> marshaling complete.');
Readln;
end;
Here is my own solution.
As I am very fond of polymorphism, I actually also want a solution that can be built into an object hierarchy. Lets say TTestObject and TTestObjectList is our BASE object. And from that we descend to TMyObject and also TMyObjectList. And furthermore I've made changes to both Object and List - added properties for Marshaller/UnMarshaller
TMyObject = class(TTestObject) and TMyObjectList<T:TMyObject> = class(TTestObjectList)
With this we now introduce some new problems. Ie. how to handle marshalling of different types between lines in the hierarchy and how to handle TJsonMarshal and TJsonUnMarshal as properties on TTestObject and List.
This can be overcome by introducing two new methods on TTestObject level. Two class functions called RegisterConverters and RegisterReverters. Then we go about and change the marshal function of TTestObjectList into a more simpel marshalling.
Two class functions and properties for both object and List.
class procedure RegisterConverters(aClass: TClass; aMar: TJSONMarshal); virtual;
class procedure RegisterReverters(aClass: TClass; aUnMar: TJSONUnMarshal); virtual;
property Mar: TJSONMarshal read FMar write SetMar;
property UnMar: TJSONUnMarshal read FUnMar write SetUnMar;
The Marshal function of List can now be done like this:
function TObjectList<T>.Marshal: TJSONObject;
begin
if FMar = nil then
FMar := TJSONMarshal.Create(); // thx. to SilverKnight
try
RegisterConverters; // Virtual class method !!!!
try
Result := FMar.Marshal(Self) as TJSONObject;
except
on e: Exception do
raise Exception.Create('Marshal Error : ' + e.Message);
end;
finally
ClearMarshal; // FreeAndNil FMar and FUnMar if assigned.
end;
end;
Sure we can still have a marshaller for our TTestObject - but the Marshal function of TTestObjectList will NOT use it. This way only ONE Marshaller will get created when calling Marshal of TTestObjectList (or descendants). And this way we end up getting marshalled ONLY the information we need to recreate our structure when doing it all backwards - UnMarshalling :-)
Now this actually works - but I wonder if anyone has any comments on this ?
Lets add a property "TimeOfCreation" to TMyTestObject:
property TimeOfCreation : TDateTime read FTimeOfCreation write FTimeOfCreation;
And set the property in the constructor.
FTimeofCreation := now;
And then we need a Converter so we override the virtual RegisterConverters of TTestObject.
class procedure TMyTestObject.RegisterConverters(aClass: TClass; aMar: TJSONMarshal);
begin
inherited; // instanciate marshaller and register TTestObject converters
aMar.RegisterConverter(aClass, 'FTimeOfCreation',
function(Data: TObject; Field: String): string
var
ctx: TRttiContext;
date: TDateTime;
begin
date := ctx.GetType(Data.ClassType).GetField(Field).GetValue(Data).AsType<TDateTime>;
Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', date);
end);
end;
I end up with Very simple source like using TTestObject ie.
aList := TMyTestObjectList<TMyTestObject>.Create;
aList.Add(TMyTestObject.Create(['one','two']));
aList.Add(TMyTestObject.Create(['three']));
s := (aList.Marshal).ToString;
Writeln(s);
And now I have succeded in marshalling with polymorphism :-)
This also works with UnMarshalling btw. And Im in the process of rebuilding my FireBird ORM to produce source for all my objects like this.
The current OLD version can be found here :
http://code.google.com/p/objectgenerator/
Remember that it only works for FireBird :-)

How to mix Interfaces and Classes by avoiding _Release to be called?

When using Interfaces in Delphi and overriding reference counting, it is possible to bypass the_Release calls Delphi makes when an interface reaches a reference count of zero.
But - when mixing classes and interfaces (which is very useful) the _Release method is ALWAYS called no matter what. The problem is that in the sample code below, the local object is nill-ed, but _Release is still called - except on invalid memory. Depending on memory operations in the application, an exception can result when _Release is called on the nilled localObject's old location or no exception if the memory was not re-used.
So, can the compiler generated call to _Release be "removed/blocked/avoided/killed/redirected/vmt hijacked/terminated/smacked/etc etc etc"? If this can be achieved you have proper pure interfaces in Delphi.
unit TestInterfaces;
interface
uses
Classes,
SysUtils;
type
ITestInterface = interface
['{92D4D6E4-A67F-4DB4-96A9-9E1C40825F9C}']
procedure Run;
end;
TTestClass = class(TInterfacedObject, ITestInterface)
protected
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
public
procedure Run;
end;
TRunTestClass = class(TObject)
protected
FlocalInterface : ITestInterface;
FlocalObject : TTestClass;
public
constructor Create;
destructor Destroy; override;
procedure Test;
end;
procedure RunTest;
procedure RunTestOnClass;
var
globalInterface : ITestInterface;
implementation
procedure RunTest;
var
localInterface : ITestInterface;
localObject : TTestClass;
begin
try
//create an object
localObject := TTestClass.Create;
//local scope
// causes _Release call when object is nilled
localInterface := localObject;
localInterface.Run;
//or global scope
// causes _Release call when exe shuts down - possibly on invalid memory location
globalInterface := localObject;
globalInterface.Run;
finally
//localInterface := nil; //--> forces _Release to be called
FreeAndNil( localObject );
end;
end;
procedure RunTestOnClass;
var
FRunTestClass : TRunTestClass;
begin
FRunTestClass := TRunTestClass.Create;
FRunTestClass.Test;
FRunTestClass.Free;
end;
{ TTheClass }
procedure TTestClass.Run;
begin
beep;
end;
function TTestClass._AddRef: Integer;
begin
result := -1;
end;
function TTestClass._Release: integer;
begin
result := -1;
end;
{ TRunTestClass }
constructor TRunTestClass.Create;
begin
FlocalObject := TTestClass.Create;
FlocalInterface := FlocalObject;
end;
destructor TRunTestClass.Destroy;
begin
//..
FlocalObject.Free;
//FlocalObject := nil;
inherited;
end;
procedure TRunTestClass.Test;
begin
FlocalInterface.Run;
end;
end.
There's no practical way to achieve what you are looking for. The compiler is going to emit the calls to _Release and in order to whack them you would need to find all the call sites. That's not practical.
I'm afraid the only viable approach when reference counted lifetime management is disabled is to ensure that you finalize (i.e. set to nil) all your interface references before calling Free.
When you use Interfaces you do not need to free your objects any more. interfaced objects will released automatically when there is no any references to same object.
In your sample you must delete _Release and _Addref functions in TTestClass they are defined in TInterfacedObject class.
In RunTest procedure you not need to Free the localObject only in finally section set globalInterface to nil. after end of procedure localInterface will destroy the local object automatically.
try
... use your code
...
finnaly
globalInnterface := nil;
end;
And about TTestRun.Destroy just left this destructor blank. you must not Free the FlocalObject.
TTestRun.Destroy;
begin
inherited;
end;

Passing object in reference / one place to style objects

I got quite a large application which is currently being styled up.
To save me changing all the buttons in the IDE/Object Inspector I am planning on just doing a few functions for the main objects like
procedure StyleButton(AButton : TButton)
begin
AButton.Color := clGreen;
AButton.Font.Style = [fsBold];
end;
etc etc and then add that to the forms onCreates as needed
StyleButton(Button1); whatever etc
There is no issue passing objects in params like this. It does just reference the first object right?
It works fine and I can't think of any issues, but because this is a large application which thousands of users I just want to be sure there will be no issues/memory leaks/resource consumpution issues.
Will also be doing similar things with TAdvStringGrid and TEdit/TMemo components.
Then allows just 1 place to change these settings.
Or someone have a better idea?
This is an excellent idea. The function will modify whichever object you pass to it.
You are not passing by reference. You are passing by value. The value you are passing is a reference. "Passing by reference" means you'd use the var or out keywords, which are not appropriate in this situation.
Your idea is just fine, as the other answerers have already said. Just want to propose a solution that goes even further than David's and something you may want to consider in order to avoid having to add many statements like:
StyleButton(Button1);
StyleButton(Button2);
to each and every form for each and every control you would like to style;
What I would propose is to add a single method call to for example each form's OnShow event:
procedure TForm1.FormShow(Sender: TObject);
begin
TStyler.StyleForm(Self);
end;
The TStyler could be implemented in a separate unit that looks like this:
interface
type
TStyler = class;
TStylerClass = class of TStyler;
TStyler = class(TObject)
public
class procedure StyleForm(const aForm: TCustomForm);
class procedure StyleControl(const aControl: TControl); virtual;
class function GetStyler(const aControl: TControl): TStylerClass;
end;
implementation
uses
Contnrs;
type
TButtonStyler = class(TStyler)
public
class procedure StyleControl(const aControl: TControl); override;
end;
TEditStyler = class(TStyler)
public
class procedure StyleControl(const aControl: TControl); override;
end;
TLabelStyler = class(TStyler)
public
class procedure StyleControl(const aControl: TControl); override;
end;
var
_Controls: TClassList;
_Stylers: TClassList;
{ TStyler }
class function TStyler.GetStyler(const aControl: TControl): TStylerClass;
var
idx: Integer;
begin
Result := TStyler;
idx := _Controls.IndexOf(aControl.ClassType);
if idx > -1 then
Result := TStylerClass(_Stylers[idx]);
end;
class procedure TStyler.StyleForm(const aForm: TCustomForm);
procedure _StyleControl(const aControl: TControl);
var
i: Integer;
StylerClass: TStylerClass;
begin
StylerClass := TStyler.GetStyler(aControl);
StylerClass.StyleControl(aControl);
if (aControl is TWinControl) then
for i := 0 to TWinControl(aControl).ControlCount - 1 do
_StyleControl(TWinControl(aControl).Controls[i]);
end;
var
i: Integer;
begin
_StyleControl(aForm);
end;
class procedure TStyler.StyleControl(const aControl: TControl);
begin
// Do nothing. This is a catch all for all controls that do not need specific styling.
end;
{ TButtonStyler }
class procedure TButtonStyler.StyleControl(const aControl: TControl);
begin
inherited;
if aControl is TButton then
begin
TButton(aControl).Font.Color := clRed;
TButton(aControl).Font.Style := [fsBold];
end;
end;
{ TEditStyler }
class procedure TEditStyler.StyleControl(const aControl: TControl);
begin
inherited;
if aControl is TEdit then
begin
TEdit(aControl).Color := clGreen;
end;
end;
{ TLabelStyler }
class procedure TLabelStyler.StyleControl(const aControl: TControl);
begin
inherited;
if aControl is TLabel then
begin
TLabel(aControl).Font.Color := clPurple;
TLabel(aControl).Font.Style := [fsItalic];
end;
end;
initialization
_Controls := TClassList.Create;
_Stylers := TClassList.Create;
_Controls.Add(TButton);
_Stylers.Add(TButtonStyler);
_Controls.Add(TEdit);
_Stylers.Add(TEditStyler);
_Controls.Add(TLabel);
_Stylers.Add(TLabelStyler);
finalization
FreeAndNiL(_Controls);
FreeAndNiL(_Stylers);
end.
This solution basically employs polymorphism and a registry that links control classes to styler classes. It also uses class procedures and functions to avoid having to instantiate anything.
Please note that the registry is implemented in this example as two lists that need to be kept in sync manually as the code assumes that finding a class at index X will find the styler at the same index in the other list. This can of course be improved upon very much, but is sufficient here to show the concept.
No, There is no issue (in your specific case) passing a object as parameter
procedure StyleButton(AButton : TButton)
when you do this you are passing a address memory (reference) and setting some properties of the referenced object, so there is not problem.
To add to what Rob and RRUZ have already said, you could consider an extra helper using open array parameters:
procedure StyleButtons(const Buttons: array of TButton);
var
i: Integer;
begin
for i := low(Buttons) to high(Buttons) do
StyleButton(Buttons[i]);
end;
You can then call this as:
StyleButtons([btnOK, btnCancel, btnRelease64bitDelphi]);
which is, in my view, more readable at the call-site than:
StyleButton(btnOK);
StyleButton(btnCancel);
StyleButton(btnRelease64bitDelphi);
Note that I passed the open array as a const parameter because that is more efficient when dealing with arrays. Because each element of the array is itself a reference to the button, you are able to modify the actual button. The const just means that you cannot change the reference.

Passing Interface's method as parameter

Is it possible to pass interface's method as parameters?
I'm trying something like this:
interface
type
TMoveProc = procedure of object;
// also tested with TMoveProc = procedure;
// procedure of interface is not working ;)
ISomeInterface = interface
procedure Pred;
procedure Next;
end;
TSomeObject = class(TObject)
public
procedure Move(MoveProc: TMoveProc);
end;
implementation
procedure TSomeObject.Move(MoveProc: TMoveProc);
begin
while True do
begin
// Some common code that works for both procedures
MoveProc;
// More code...
end;
end;
procedure Usage;
var
o: TSomeObject;
i: ISomeInterface;
begin
o := TSomeObject.Create;
i := GetSomeInterface;
o.Move(i.Next);
// somewhere else: o.Move(i.Prev);
// tested with o.Move(#i.Next), ##... with no luck
o.Free;
end;
But it is not working because:
E2010 Incompatible types: 'TMoveProc' and 'procedure, untyped pointer or untyped parameter'
Of course I can do private method for each call, but that is ugly. Is there any better way?
Delphi 2006
Edit:
I know that I can pass whole interface, but then I have to specify which function use. I don't want two exactly same procedures with one different call.
I can use second parameter, but that is ugly too.
type
SomeInterfaceMethod = (siPred, siNext)
procedure Move(SomeInt: ISomeInterface; Direction: SomeInterfaceMethod)
begin
case Direction of:
siPred: SomeInt.Pred;
siNext: SomeInt.Next
end;
end;
Thanks all for help and ideas. Clean solution (for my Delphi 2006) is Diego's Visitor. Now I'm using simple ("ugly") wrapper (my own, same solution by TOndrej and Aikislave).
But true answer is "there is no (direct) way to pass interface's methods as parameters without some kind of provider.
If you were using Delphi 2009, you could do this with an anonymous method:
TSomeObject = class(TObject)
public
procedure Move(MoveProc: TProc);
end;
procedure Usage;
var
o: TSomeObject;
i: ISomeInterface;
begin
o := TSomeObject.Create;
i := GetSomeInterface;
o.Move(procedure() begin i.Next end);
The problem with trying to pass a reference to just the interface method is that you are not passing a reference to the interface itself, so the interface cannot be reference counted. But anonymous methods are themselves reference counted, so the interface reference inside the anonymous method here can be reference counted as well. That is why this method works.
I don't know the exact reason why you need to do that, but, personally, I think it would be better to pass the whole "Mover" object instead of one of its methods. I used this approach in the past, it's called "Visitor" pattern.
tiOPF, an object persistence framework, uses it extensively and gives you a good example of how it works: The Visitor Pattern and the tiOPF.
It's relatively long, but it proved very useful to me, even when I didn't use tiOPF. Note step 3 in the document, titled "Step #3. Instead of passing a method pointer, we will pass an object".
DiGi, to answer your comment: If you use Visitor pattern, then you don't have an interface implementing multiple methods, but just one (Execute). Then you'd have a class for each action, like TPred, TNext, TSomething, and you pass an instance of such classes to the object to be processed. In such way, you don't have to know what to call, you just call "Visitor.Execute", and it will do the job.
Here you can find a basic example:
interface
type
TVisited = class;
TVisitor = class
procedure Execute(Visited: TVisited); virtual; abstract;
end;
TNext = class(TVisitor)
procedure Execute (Visited: TVisited); override;
end;
TPred = class(TVisitor)
procedure Execute (Visited: TVisited); override;
end;
TVisited = class(TPersistent)
public
procedure Iterate(pVisitor: TVisitor); virtual;
end;
implementation
procedure TVisited.Iterate(pVisitor: TVisitor);
begin
pVisitor.Execute(self);
end;
procedure TNext.Execute(Visited: TVisited);
begin
// Implement action "NEXT"
end;
procedure TPred.Execute(Visited: TVisited);
begin
// Implement action "PRED"
end;
procedure Usage;
var
Visited: TVisited;
Visitor: TVisitor;
begin
Visited := TVisited.Create;
Visitor := TNext.Create;
Visited.Iterate(Visitor);
Visited.Free;
end;
Although the wrapper class solution works, I think that's an overkill. It's too much code, and you have to manually manage the lifetime of the new object.
Perhaps a simpler solution would be to create methods in the interface that returns TMoveProc
ISomeInterface = interface
...
function GetPredMeth: TMoveProc;
function GetNextMeth: TMoveProc;
...
end;
The class that implements the interface can provide the procedure of object and it will be accessible through the interface.
TImplementation = class(TInterfaceObject, ISomeInterface)
procedure Pred;
procedure Next;
function GetPredMeth: TMoveProc;
function GetNextMeth: TMoveProc;
end;
...
function TImplementation.GetPredMeth: TMoveProc;
begin
Result := Self.Pred;
end;
function TImplementation.GetNextMeth: TMoveProc;
begin
Result := Self.Next;
end;
How about this:
type
TMoveProc = procedure(const SomeIntf: ISomeInterface);
TSomeObject = class
public
procedure Move(const SomeIntf: ISomeInterface; MoveProc: TMoveProc);
end;
procedure TSomeObject.Move(const SomeIntf: ISomeInterface; MoveProc: TMoveProc);
begin
MoveProc(SomeIntf);
end;
procedure MoveProcNext(const SomeIntf: ISomeInterface);
begin
SomeIntf.Next;
end;
procedure MoveProcPred(const SomeIntf: ISomeInterface);
begin
SomeIntf.Pred;
end;
procedure Usage;
var
SomeObj: TSomeObject;
SomeIntf: ISomeInterface;
begin
SomeIntf := GetSomeInterface;
SomeObj := TSomeObject.Create;
try
SomeObj.Move(SomeIntf, MoveProcNext);
SomeObj.Move(SomeIntf, MoveProcPred);
finally
SomeObj.Free;
end;
end;
Here is another solution that is working in Delphi 20006. It is similar to the idea of #Rafael, but using interfaces:
interface
type
ISomeInterface = interface
//...
end;
IMoveProc = interface
procedure Move;
end;
IMoveProcPred = interface(IMoveProc)
['{4A9A14DD-ED01-4903-B625-67C36692E158}']
end;
IMoveProcNext = interface(IMoveProc)
['{D9FDDFF9-E74E-4F33-9CB7-401C51E7FF1F}']
end;
TSomeObject = class(TObject)
public
procedure Move(MoveProc: IMoveProc);
end;
TImplementation = class(TInterfacedObject,
ISomeInterface, IMoveProcNext, IMoveProcPred)
procedure IMoveProcNext.Move = Next;
procedure IMoveProcPred.Move = Pred;
procedure Pred;
procedure Next;
end;
implementation
procedure TSomeObject.Move(MoveProc: IMoveProc);
begin
while True do
begin
// Some common code that works for both procedures
MoveProc.Move;
// More code...
end;
end;
procedure Usage;
var
o: TSomeObject;
i: ISomeInterface;
begin
o := TSomeObject.Create;
i := TImplementation.Create;
o.Move(i as IMoveProcPred);
// somewhere else: o.Move(i as IMoveProcNext);
o.Free;
end;
You can't. Because of the scoping of Interfaces it would be possible (perhaps?) for the Interface to be released before you called the .Next function. If you want to do this you should pass the whole interface to your method rather than just a method.
Edited...
Sorry, this next bit, specifically the "Of Interface" bit was meant in jest.
Also, and I could be wrong here, i.Next is not a method Of Object, as per your type def, it would be a method Of Interface!
Redefine your function
TSomeObject = class(TObject)
public
procedure Move(Const AMoveIntf: ISomeInterface);
end;
Procedure TSomeObject.Move(Const AMoveIntf : ISomeInterface);
Begin
....;
AMoveIntf.Next;
end;
O.Move(I);
Hope this helps.
You currently have TMoveProc defined as
TMoveProc = procedure of object;
Try taking out the "of object" which implies a hidden "this" pointer as first parameter.
TMoveProc = procedure;
That should allow a normal procedure to be called.

Resources