How to link "parallel" class hierarchy? - delphi

Question

I've got a little class hierarchy where each class corresponds to a certain TComponent descendent (say base class TDefaultFrobber with descendents TActionFrobber and TMenuItemFrobber, corresponding to TComponent, TCustomAction and TMenuItem, respectively). Now I want a factory (?) function something like this:
function CreateFrobber(AComponent: TComponent): IFrobber;
begin
if AComponent is TCustomAction then
Result := TActionFrobber.Create(TCustomAction(AComponent))
else if AComponent is TMenuItem then
Result := TMenuItemFrobber.Create(TMenuItem(AComponent))
else
Result := TDefaultFrobber.Create(AComponent);
end;
Can I somehow refactor this to use virtual functions or something similar instead of the if-else cascade or RTTI?
Edit: My solution for now:
unit Frobbers;
interface
uses
Classes;
type
IComponentFrobber = interface
end;
TComponentFrobberClass = class of TComponentFrobber;
TComponentFrobber = class(TInterfacedObject, IComponentFrobber)
strict private
FComponent: TComponent;
protected
constructor Create(AComponent: TComponent);
property Component: TComponent read FComponent;
public
class function FindFrobberClass(AComponentClass: TComponentClass): TComponentFrobberClass; overload; static;
class function FindFrobberClass(AComponent: TComponent): TComponentFrobberClass; overload; static;
class procedure RegisterFrobber(AComponentClass: TComponentClass; AFrobberClass: TComponentFrobberClass); static;
end;
implementation
uses
ActnList,
Menus;
type
TComponentFrobberRegistryItem = record
ComponentClass: TComponentClass;
FrobberClass: TComponentFrobberClass;
end;
var
FComponentFrobberRegistry: array of TComponentFrobberRegistryItem;
class function TComponentFrobber.FindFrobberClass(AComponentClass: TComponentClass): TComponentFrobberClass;
var
i: Integer;
begin
// Search backwards, so that more specialized frobbers are found first:
for i := High(FComponentFrobberRegistry) downto Low(FComponentFrobberRegistry) do
if FComponentFrobberRegistry[i].ComponentClass = AComponentClass then
begin
Result := FComponentFrobberRegistry[i].FrobberClass;
Exit;
end;
Result := nil;
end;
constructor TComponentFrobber.Create(AComponent: TComponent);
begin
inherited Create;
FComponent := AComponent;
end;
class function TComponentFrobber.FindFrobberClass(AComponent: TComponent): TComponentFrobberClass;
var
i: Integer;
begin
// Search backwards, so that more specialized frobbers are found first:
for i := High(FComponentFrobberRegistry) downto Low(FComponentFrobberRegistry) do
if AComponent is FComponentFrobberRegistry[i].ComponentClass then
begin
Result := FComponentFrobberRegistry[i].FrobberClass;
Exit;
end;
Result := nil;
end;
class procedure TComponentFrobber.RegisterFrobber(AComponentClass: TComponentClass;
AFrobberClass: TComponentFrobberClass);
var
i: Integer;
begin
Assert(FindFrobberClass(AComponentClass) = nil, 'Duplicate Frobber class');
i := Length(FComponentFrobberRegistry);
SetLength(FComponentFrobberRegistry, Succ(i));
FComponentFrobberRegistry[i].ComponentClass := AComponentClass;
FComponentFrobberRegistry[i].FrobberClass := AFrobberClass;
end;
function CreateComponentFrobber(AComponent: TComponent): IComponentFrobber;
var
FrobberClass: TComponentFrobberClass;
begin
FrobberClass := TComponentFrobber.FindFrobberClass(AComponent);
Assert(FrobberClass <> nil);
Result := FrobberClass.Create(AComponent);
end;
type
TActionFrobber = class(TComponentFrobber);
TMenuItemFrobber = class(TComponentFrobber);
initialization
TComponentFrobber.RegisterFrobber(TCustomAction, TActionFrobber);
TComponentFrobber.RegisterFrobber(TMenuItem, TMenuItemFrobber);
end.
Thanks to Cesar, Gamecat and mghie.

Answer 1

If you create a class with a virtual constructor and create a class type for that class. You can create a lookuplist based on the component class name.
Example:
type
TFrobber = class
public
constructor Create; virtual;
class function CreateFrobber(const AComponent: TComponent): TFrobber;
end;
TFrobberClass = class of TFrobber;
type
TFrobberRec = record
ClassName: ShortString;
ClassType: TFrobberClass;
end;
const
cFrobberCount = 3;
cFrobberList : array[1..cFrobberCount] of TFrobberRec = (
(ClassName : 'TAction'; ClassType: TActionFrobber),
(ClassName : 'TButton'; ClassType: TButtonFrobber),
(ClassName : 'TMenuItem'; ClassType: TMenuItemFrobber)
);
class function TFrobber.CreateFrobber(const AComponent: TComponent): TFrobber;
var
i : Integer;
begin
Result := nil;
for i := 1 to cFrobberCount do begin
if AComponent.ClassName = cFrobberList[i].ClassName then begin
Result := cFrobberList[i].ClassType.Create();
Exit;
end;
end;
end;
You can of course also work with a dynamic list (dictionary) but then you must register each combination somehow.
Update
To commnent on the remarks of mghie.
You are perfectly right. But this is not possibly without really ugly tricks.
Right now you have to use the initialization/finalization sections of a unit to regoister a class. But it would be cool to add a initialization/finalization class method to a class. These have to be called along with the initialization (and finalization) of the unit. Like this:
class
TFrobber = class
private
initialization Init; // Called at program start just after unit initialization
finalization Exit; // called at program end just before unit finalization.
end;

Answer 2

2 suggestions:
Make class pair array of classes, then you can get the Index and use the pair of the class constructor,
var
ArrayItem: array[0..1] of TComponentClass = (TActionFrobber, TMenuItemFrobber);
ArrayOwner: array[0..1] of TComponentClass = (TCustomAction, TMenuItem);
function CreateFrobber(AComponent: TComponentClass): IFrobber;
var
Index: Integer;
begin
Result:= nil;
for I := Low(ArrayOwner) to High(ArrayOwner) do
if AComponent is ArrayOwner[I] then
begin
Result:= ArrayItem[I].Create(AComponent);
Break;
end;
if Result = nil then
Result:= TDefaultFrobber.Create(AComponent);
end;
or use RTTI + ClassName conventions, like this:
function CreateFrobber(AComponent: TComponentClass): IFrobber;
const
FrobberClassSuffix = 'Frobber';
var
LClass: TComponentClass;
LComponent: TComponent;
begin
LClass:= Classes.FindClass(AComponent.ClassName + FrobberClassSuffix);
if LClass <> nil then
LComponent:= LClass.Create(AComponent)
else
LComponent:= TDefaultFrobber.Create(AComponent);
if not Supports(LComponent, IFrobber, Result) then
Result:= nil;
end;

Answer 3

I'd like to add some comments to your current solution, answering here as this can not really be done in the comments section:
type
IComponentFrobber = interface
end;
TComponentFrobberClass = class of TComponentFrobber;
TComponentFrobber = class(TInterfacedObject, IComponentFrobber)
strict private
FComponent: TComponent;
protected
constructor Create(AComponent: TComponent);
property Component: TComponent read FComponent;
public
class function FindFrobberClass(AComponentClass: TComponentClass):
TComponentFrobberClass; overload; static;
class function FindFrobberClass(AComponent: TComponent):
TComponentFrobberClass; overload; static;
class procedure RegisterFrobber(AComponentClass: TComponentClass;
AFrobberClass: TComponentFrobberClass); static;
end;
There is not much point in using TInterfacedObject for the base class, as you will always need the object, not the interface it implements - how else would you find your concrete Frobber class? I would split this into TComponentFrobber, descending from TInterfacedObject, and a TComponentRegistry class (descending from TObject) that has the class methods. You can then of course make the registry class more generic, it is not tied to TComponentFrobber and could be reused.
Edit: I have used similar class registries for example when loading files: load the identifier for the next object (could be for example string, integer or GUID), then get the correct class to instantiate from the registry, then create and load the object.
type
TComponentFrobberRegistryItem = record
ComponentClass: TComponentClass;
FrobberClass: TComponentFrobberClass;
end;
var
FComponentFrobberRegistry: array of TComponentFrobberRegistryItem;
This is OK if you will never add or remove classes to / from the registry, but generally I would not use an array but a list for the registry entries.
class function TComponentFrobber.FindFrobberClass(AComponentClass: TComponentClass):
TComponentFrobberClass;
var
i: Integer;
begin
// Search backwards, so that more specialized frobbers are found first:
for i := High(FComponentFrobberRegistry) downto Low(FComponentFrobberRegistry) do
if FComponentFrobberRegistry[i].ComponentClass = AComponentClass then
begin
Result := FComponentFrobberRegistry[i].FrobberClass;
Exit;
end;
Result := nil;
end;
Searching backwards in the array will not help for finding the most specialized frobber, unless you add them in the correct order (least specialized first). Why don't you check for the ClassType being equal? There is also ClassParent to traverse the class hierarchy, if you need to test for base classes too.