How to connect the "parallel" class hierarchy?

Question

I have a small class hierarchy where each class corresponds to a specific TComponent descendant (for example, a TDefaultFrobber base class with TActionFrobber and TMenuItemFrobber descendants corresponding to TComponent, TCustomAction, and TMenuItem, respectively). Now I want the factory (?) Function to look 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; 

Is it possible to somehow reorganize this to use virtual functions or something similar instead of the if-else or RTTI cascade?

Edit: My solution:

 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

2 sentences: Create a class of classes of pairs of classes, then you can get the index and use a couple of class constructors,

 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 the RTTI + ClassName conventions, for example:

 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 2

If you create a class with a virtual constructor and create a class for this class. You can create a search list 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; 

Of course, you can also work with a dynamic list (dictionary), but then you must somehow register each combination.

Update

To take into account mghie's comments.

You are absolutely right. But this is not possible without ugly tricks. Right now, you should use the unit initialization / shutdown sections to reinstall the class. But it would be great to add an initialization / refinement class class. They should be called along with the initialization (and completion) of the block. 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 3

I would like to add some comments to your current solution by answering here, as this cannot 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; 

It makes no sense to use TInterfacedObject for the base class, since you always need an object, not an interface that it implements - how else would you find your specific Frobber class? I would split it into TComponentFrobber, go down from TInterfacedObject and the TComponentRegistry class (descent from TObject) which has class methods. You can, of course, make the registry class more general, it is not tied to TComponentFrobber and can be reused.

Edit: I used similar class registries, for example, when downloading files: load the identifier for the next object (maybe, for example, string, integer or GUID), and then get the correct class to create an instance from the registry, then create and load the object.

 type TComponentFrobberRegistryItem = record ComponentClass: TComponentClass; FrobberClass: TComponentFrobberClass; end; var FComponentFrobberRegistry: array of TComponentFrobberRegistryItem; 

This is normal if you never add or remove classes from the registry, but usually I would not use an array, but a list for 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 back in the array will not help find the most specialized frobber unless you add them in the correct order (the least specialized first). Why don't you check if ClassType is equal? There is also a ClassParent to traverse the class hierarchy if you need to check the base classes as well.