Generic factory - delphi

Question

suppose I have a TModel:
TModelClass = class of TModel;
TModel = class
procedure DoSomeStuff;
end;
and 2 descendants:
TModel_A = class(TModel);
TModel_B = class(TModel);
and a factory :
TModelFactory = class
class function CreateModel_A: TModel_A;
class function CreateModel_B: TModel_B;
end;
Now I want to refactor a bit :
TModelFactory = class
class function CreateGenericModel(Model: TModelClass) : TModel
end;
class function TModelFactory.CreateGenericModel(Model: TModelClass) : TModel
begin
...
case Model of
TModel_A: Result := TModel_A.Create;
TModel_B: Result := TModel_B.Create;
end;
...
end;
So far it's ok, but every time I create a TModel descendant, I have to modify the factory case statement.
My question: Is this possible to create a 100% generic factory for all my TModel descendants, so every time I create a TModel descendants I don't have to modify TModelFactory ?
I tried to play with Delphi 2009 generics but didn't find valuable information, all are related to basic usage of TList<T>and so on.
Update
Sorry, but maybe I'm not clear or don't understand your answer (I'm still a noob), but what i'm trying to achieve is :
var
M: TModel_A;
begin
M: TModelFactory.CreateGenericModel(MY_CONCRETE_CLASS);

Answer 1

Well, you could write
class function TModelFactory.CreateGenericModel(AModelClass: TModelClass): TModel;
begin
Result := AModelClass.Create;
end;
but then you don't need a factory any more. Usually one would have a selector of a different type, like an integer or string ID, to select the concrete class the factory should create.
Edit:
To answer your comment on how to add new classes without the need to change the factory - I will give you some simple sample code that works for very old Delphi versions, Delphi 2009 should upen up much better ways to do this.
Each new descendant class only needs to be registered with the factory. The same class can be registered using several IDs. The code uses a string ID, but integers or GUIDs would work just as well.
type
TModelFactory = class
public
class function CreateModelFromID(const AID: string): TModel;
class function FindModelClassForId(const AID: string): TModelClass;
class function GetModelClassID(AModelClass: TModelClass): string;
class procedure RegisterModelClass(const AID: string;
AModelClass: TModelClass);
end;
{ TModelFactory }
type
TModelClassRegistration = record
ID: string;
ModelClass: TModelClass;
end;
var
RegisteredModelClasses: array of TModelClassRegistration;
class function TModelFactory.CreateModelFromID(const AID: string): TModel;
var
ModelClass: TModelClass;
begin
ModelClass := FindModelClassForId(AID);
if ModelClass <> nil then
Result := ModelClass.Create
else
Result := nil;
end;
class function TModelFactory.FindModelClassForId(
const AID: string): TModelClass;
var
i, Len: integer;
begin
Result := nil;
Len := Length(RegisteredModelClasses);
for i := 0 to Len - 1 do
if RegisteredModelClasses[i].ID = AID then begin
Result := RegisteredModelClasses[i].ModelClass;
break;
end;
end;
class function TModelFactory.GetModelClassID(AModelClass: TModelClass): string;
var
i, Len: integer;
begin
Result := '';
Len := Length(RegisteredModelClasses);
for i := 0 to Len - 1 do
if RegisteredModelClasses[i].ModelClass = AModelClass then begin
Result := RegisteredModelClasses[i].ID;
break;
end;
end;
class procedure TModelFactory.RegisterModelClass(const AID: string;
AModelClass: TModelClass);
var
i, Len: integer;
begin
Assert(AModelClass <> nil);
Len := Length(RegisteredModelClasses);
for i := 0 to Len - 1 do
if (RegisteredModelClasses[i].ID = AID)
and (RegisteredModelClasses[i].ModelClass = AModelClass)
then begin
Assert(FALSE);
exit;
end;
SetLength(RegisteredModelClasses, Len + 1);
RegisteredModelClasses[Len].ID := AID;
RegisteredModelClasses[Len].ModelClass := AModelClass;
end;

Answer 2

Result := Model.Create;
should work, too.

Answer 3

The solution with Model.Create works if the constructor is virtual.
If you use delphi 2009, you can use another trick using generics:
type
TMyContainer<T: TModel, constructor> (...)
protected
function CreateModel: TModel;
end;
function TMyContainer<T>.CreateModel: TModel;
begin
Result := T.Create; // Works only with a constructor constraint.
end;

Answer 4

If I understand your question properly, I wrote something similar here http://www.malcolmgroves.com/blog/?p=331

Answer 5

There is probably a simpler way to accomplish this. I seem to remember finding the built-in TClassList object that handled this, but that this point I already had this working. TClassList does not have a way to look up the stored objects by the string name, but it could still be useful.
Basically to make this work you need to register your classes with a global object. That way it can take a string input for the class name, lookup that name in a list to find the correct class object.
In my case I used a TStringList to hold the registered classes and I use the class name as the identifier for the class. In order to add the class to the "object" member of the string list I needed to wrap the class in a real object. I'll admit that I don't really understand the "class" so this may not be needed if you cast everything right.
// Needed to put "Class" in the Object member of the
// TStringList class
TClassWrapper = class(TObject)
private
FGuiPluginClass: TAgCustomPluginClass;
public
property GuiPluginClass: TAgCustomPluginClass read FGuiPluginClass;
constructor Create(GuiPluginClass: TAgCustomPluginClass);
end;
I have a global "PluginManager" object. This is where classes get registered and created. The "AddClass" method puts the class in the TStringList so I can look it up later.
procedure TAgPluginManager.AddClass(GuiPluginClass: TAgCustomPluginClass);
begin
FClassList.AddObject(GuiPluginClass.ClassName,
TClassWrapper.Create(GuiPluginClass));
end;
In each class that I create I add it to the class list in the "initialization" section.
initialization;
AgPluginManager.AddClass(TMyPluginObject);
Then, when it comes time to create the class I can lookup the name in the string list, find the class and create it. In my actual function I am checking to make sure the entry exists and deal with errors, etc. I am also passing in more data to the class constructor. In my case I am creating forms so I don't actually return the object back to the caller (I track them in my PluginManager), but that would be easy to do if needed.
procedure TAgPluginManager.Execute(PluginName: string);
var
ClassIndex: integer;
NewPluginWrapper: TClassWrapper;
begin
ClassIndex := FClassList.IndexOf(PluginName);
if ClassIndex > -1 then
begin
NewPluginWrapper := TClassWrapper(FClassList.Objects[ClassIndex]);
FActivePlugin := NewPluginWrapper.GuiPluginClass.Create();
end;
end;
Since I first wrote this I have not needed to touch the code. I just make sure to add my new classes to the list in their initialization section and everything works.
To create an object I just call
PluginManger.Execute('TMyPluginObject');

Answer 6

You can do generic factory like this: But the only issue you should set the generic construct method to it for each of the factory final class like this:
type
TViewFactory = TGenericFactory<Integer, TMyObjectClass, TMyObject>;
...
F := TViewFactory.Create;
F.ConstructMethod :=
function(AClass: TMyObjectClass; AParams: array of const): TMyObject
begin
if AClass = nil then
Result := nil
else
Result := AClass.Create;
end;
and the unit for the factory is:
unit uGenericFactory;
interface
uses
System.SysUtils, System.Generics.Collections;
type
EGenericFactory = class(Exception)
public
constructor Create; reintroduce;
end;
EGenericFactoryNotRegistered = class(EGenericFactory);
EGenericFactoryAlreadyRegistered = class(EGenericFactory);
TGenericFactoryConstructor<C: constructor; R: class> = reference to function(AClass: C; AParams: array of const): R;
TGenericFactory<T; C: constructor; R: class> = class
protected
FType2Class: TDictionary<T, C>;
FConstructMethod: TGenericFactoryConstructor<C, R>;
procedure SetConstructMethod(const Value: TGenericFactoryConstructor<C, R>);
public
constructor Create(AConstructor: TGenericFactoryConstructor<C, R> = nil); reintroduce; overload; virtual;
destructor Destroy; override;
procedure RegisterClass(AType: T; AClass: C);
function ClassForType(AType: T): C;
function TypeForClass(AClass: TClass): T;
function SupportsClass(AClass: TClass): Boolean;
function Construct(AType: T; AParams: array of const): R;
property ConstructMethod: TGenericFactoryConstructor<C, R> read FConstructMethod write SetConstructMethod;
end;
implementation
uses
System.Rtti;
{ TGenericFactory<T, C, R> }
function TGenericFactory<T, C, R>.ClassForType(AType: T): C;
begin
FType2Class.TryGetValue(AType, Result);
end;
function TGenericFactory<T, C, R>.Construct(AType: T; AParams: array of const): R;
begin
if not Assigned(FConstructMethod) then
Exit(nil);
Result := FConstructMethod(ClassForType(AType), AParams);
end;
constructor TGenericFactory<T, C, R>.Create(AConstructor: TGenericFactoryConstructor<C, R> = nil);
begin
inherited Create;
FType2Class := TDictionary<T, C>.Create;
FConstructMethod := AConstructor;
end;
destructor TGenericFactory<T, C, R>.Destroy;
begin
FType2Class.Free;
inherited;
end;
procedure TGenericFactory<T, C, R>.RegisterClass(AType: T; AClass: C);
begin
if FType2Class.ContainsKey(AType) then
raise EGenericFactoryAlreadyRegistered.Create;
FType2Class.Add(AType, AClass);
end;
procedure TGenericFactory<T, C, R>.SetConstructMethod(const Value: TGenericFactoryConstructor<C, R>);
begin
FConstructMethod := Value;
end;
function TGenericFactory<T, C, R>.SupportsClass(AClass: TClass): Boolean;
var
Key: T;
Val: C;
begin
for Key in FType2Class.Keys do
begin
Val := FType2Class[Key];
if CompareMem(#Val, AClass, SizeOf(Pointer)) then
Exit(True);
end;
Result := False;
end;
function TGenericFactory<T, C, R>.TypeForClass(AClass: TClass): T;
var
Key: T;
Val: TValue;
begin
for Key in FType2Class.Keys do
begin
Val := TValue.From<C>(FType2Class[Key]);
if Val.AsClass = AClass then
Exit(Key);
end;
raise EGenericFactoryNotRegistered.Create;
end;
{ EGenericFactory }
constructor EGenericFactory.Create;
begin
inherited Create(Self.ClassName);
end;
end.