views:

407

answers:

3

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.

+3  A: 

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;
Gamecat
+1 on the idea, but definitely go with dynamically registered pairs of standard classes and matching Frobber classes. This way you get looser coupling between everything. There's no need that the class registry needs to know all concrete classes, as the code in the answer necessitates.
mghie
Perfect design is achieved IMO when a new Frobber class can be added to the system by just adding a new unit, without changes to old code.
mghie
I'm really looking for a more "compile time safe" approach, but I guess a RegisterClass-type is the closest I get. Maybe with TComponentClass instead of class name like Cesar proposed.
Ulrich Gerhardt
There is a slight problem with using component class for comparison, because it can cause any component to match the component class. That's why I used classname, just to be safe.
Gamecat
@Gamecat: Re your edit - I don't see the need to register in the initialization clause as a real problem. If that's not wanted, then one can of course also register the Frobber class manually. That opens the door to runtime changes of available Frobber classes too. Class initialization looks nice!
mghie
But how should any component match a component class? Could you please clarify?
mghie
@Ulrich Gerhardt: If you are using interfaces in your program, then GUID is a perfectly usable key for the class registry too.
mghie
@mghie, re: match: I guess Gamecat refers to the fact that a test for TComponent matches *any* component, so you have to be careful with the order of the RegisterFrobber calls. I guess searching backwards in the frobber registry should work.
Ulrich Gerhardt
@Ulrich Gerhardt: This can be fixed by checking for equality of ClassType. I have actually coded this once with a loop - testing for ClassType, if not found retrying with the parent class, upwards until TObject. This kind of flexibility is not often needed, though.
mghie
+2  A: 

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;
Cesar Romero
The RTTI + ClassName convention idea is too fragile IMO, why paint oneself into such a corner?
mghie
I agree, and prefer class pair arrays. I just bring up one more option. It is up to to him to use or not, at least he knows that this can be done in this way.
Cesar Romero
A: 

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.

mghie
The IComponentFrobber interface is purely for lifetime management - no try/finally necessary when using frobbers. I guess I could use some IObjectSafe implementation instead.
Ulrich Gerhardt
Re array: An array is just simpler to use - no need to free it, no need to derive a container class, that can hold pairs of pointers etc. Removing from the registry won't occur - only calls to RegisterFrobber in initialization sections AFAICT now.
Ulrich Gerhardt
OK. It's not that you should change your code, maybe it will help someone else some time, StackOverflow is to become wiki-like after all.
mghie
Didn't understand it that way. I just appreciate your comments.
Ulrich Gerhardt