I have a memory Management issue. Can you help me?
What I know:
any object that has been created has to be destroyed.
if the type of an object is an interface to that object, then whenever that variable cease to exist the object will be destroyed, and the memory is returned to the heap (if there is no reference count left)
(what I am not sure of) if an object contains (an/more) object(s), you should write a destructor always (?):
that destructor should have the "inherited;" word written somewhere (I think at the end)
that destructor should free any objectList, object ... etc (which in turn may call that object's destructor, etc)
In the case of number 2:
will the memory of the objects IN that object be freed?
They might continue to exist - creating a memory leak
In order to avoid this during chained method calls (services.repository.method : Result.create(object)
Second part : I try to use interfaces ...
Memory issues with functions resulting in creations of T/interfacesOfT/:
type
TorderLine = class(TPersistent)
private
productId: integer;
productName : string;
amount : real;
price : real;
public
create(productId: integer; productName: string; amount, price: real);
function getId: integer;
funciton getProductName: string;
function getamount: real;
function getprice: real;
end;
TorderLines = class (TPersistent)
private
orderlines: TObjectList<OrderLine>;
public
create;
create(list: TStringList);
procedure addOrderLine(orderline: TOrderLine);
function getOrderLines: TObjectList;
function SearchOrderLines(productId: integer): TOrderLine;
destructor; { must exist in order to free the TObjectList
is only called when TOrder.Free is called }
end;
iOrder = interface
function getOrderId: integer;
function getSupplierId;
function getorderLines: TOrderLines;
function toString: string;
end;
iOrderHeader = interface
function getOrderId;
function getSupplierId;
function toString: string;
end;
TOrder = class(InterFacedObject, iOrder, iOrderHeader);
private
orderId: integer;
supplierId: integer;
orderLines: TOrderLines;
public
create(orderId, supplierId: integer; orderLines: TOrderLines);
function getOrderId: integer;
function getSupplierId: integer;
function getorderLines: TOrderLines;
function toString: string;
end;
iOrderRepository = interface
function findOrder(orderId: integer): TOrder;
function updateOrder(order: iOrder): integer;
function findInterFaceOfOrder(orderId: integer): iOrder;
end;
TOrderRepository = class (InterFacedObject, iOrderRepository)
function findOrder(orderId: integer): TOrder; { Here the TOrder.Create WITH TorderLines.create is done }
procedure updateOrder(order: iOrder): integer;
end;
Procedure blahblahblah;
var
iorder: iOrder;
begin
iorder := orderRepository.findOrder(someInteger);
writeln(iorder.toString);
{ don't worry here : no free has to be done }
end
var
order : Torder;
iorder: iOrder;
iorderHeader: iOrderHeader;
orderRepository : iOrderRepository
begin {main }
orderRepository := TOrderRepository.create;
order := orderRepository.findOrder(someInteger);
iOrder := order; { case 2 }
iOrderHeader := order; { case 3 }
blahblahblah;
order.free; { case 1 }
{ the Torder.Free is called, which in term calls TorderList.free}
{ we don't care about iOrder & iOrderHeader }
order := orderRepository.findInterFaceOfOrder(someInteger); { Gives an error } {Case 5}
iorder := orderRepository.findInterFaceOfOrder(someInteger); { works fine } {Case 4}
end.
{ Above should be Correct code with no memory leak
More Abstract }
function F : T (Result : T.create)
function G : interfaceOfT (Restul:T.Create)
function H : otherInterfaceOfT (Result: T.Create)
{ case 1 } x := F -> should work ok <memory has to be freed manually>
{ case 2 } y := F -> should work ok <memory does not have to be freed : Is that so ?>
{ case 3 } z := F -> should work ok <memory does not have to be freed : Is that SO ?>
{ case 4 } y := G -> should work ok <memory should not have to be freed>
{ case 5 } z := G : does not work
Are the above assumptions correct?
Additionally : when in the blahblahblah, the Order object (iOrder) is freed, then also the TOrderLines are freed? Or, are they lost in cyberspace?
Related
In C++, you can explicitly define a unique specialization for a templated function, like (to steal an example)
// A generic sort function
template <class T>
void sort(T arr[], int size)
{
// code to implement Quick Sort
}
// Template Specialization: A function
// specialized for char data type
template <>
void sort<char>(char arr[], int size)
{
// code to implement counting sort
}
Is there a way to do the equivalent with Delphi generic methods? When I try
function TryStrConv<T>(S: string; var Val: T): boolean;
function TryStrConv<float>(S: string; var Val: float): boolean;
I get warnings about how I have to use the Overload directive.
What I'm hoping to get is a way to write a generic TryStrConv where the default instantiation returns false and does nothing, while the int and float instantiations, which I want to provide explicitly, use TryStrToInt and TryStrToFloat. Alternatively, if there's a generic conversion facility in Delphi that I'm missing, I'd like to get pointed at it.
Thanks.
You cannot at declaration already fill the generic argument. You either overload with one generic method and one without being generic like this:
function TryStrConv<T>(S: string; var Val: T): boolean; overload;
function TryStrConv(S: string; var Val: Extended): boolean; overload;
But need to be aware that it only picks the non generic one for Extended and not the other floating point types Delphi has like Double or Single.
Another way can be if you are on a version of Delphi XE7 or higher to use the new intrinsic functions to branch the generic methods implementation (it gets resolved at compiletime and the non executed path gets eliminated). It could for example look like this (I omitted the type of the TryStrConv method but you know in Delphi you cannot have generic standalone routines but they have to be methods of some type even if just static):
function TryStrConv<T>(S: string; var Val: T): boolean;
begin
if GetTypeKind(T) = tkFloat then
begin
// do stuff with val being a float type, still need to handle the different float types though
case GetTypeData(TypeInfo(T)) of
ftDouble: DoStuffWithDouble;
// if you need to pass Val here you might need to do some pointer
// ref/deref hardcasts like PDouble(#Val)^ because otherwise you
// are not allowed to cast type T to Double (or any other type)
....
end;
else
Result := False;
end;
You can do something similar like this:
Type
TCalc = record
class function TryStrConv(S: string; var Val: Double): boolean; overload; static;
class function TryStrConv(S: string; var Val: integer): boolean; overload; static;
class function TryStrConv<T>(S: string; var Val: T): boolean; overload; static;
end;
{ TCalc }
class function TCalc.TryStrConv(S: string; var Val: Double): boolean;
begin
Result := TryStrToFloat(s,Val);
end;
class function TCalc.TryStrConv(S: string; var Val: integer): boolean;
begin
Result := TryStrToInt(S,Val);
end;
class function TCalc.TryStrConv<T>(S: string; var Val: T): boolean;
begin
Result := false;
end;
And testing:
var
iVal : Integer;
dVal : Double;
sVal : String;
ok : Boolean;
begin
ok := TCalc.TryStrConv('12',iVal);
WriteLn(ok,' ',iVal); // True 12
ok := TCalc.TryStrConv('12',dVal);
WriteLn(ok,' ',dVal); // True 1.2 E+1
ok := TCalc.TryStrConv('12',sVal);
WriteLn(ok,' ',sVal); // False
ReadLn;
end.
As Stefan says: You will have to write a specific function for each of the float types.
Indeed there is a lot of stuff online about this but more I read more confuse I am. I have written a component called Combinatorics that does some math probability stuff. The code is pretty short and easy because I don't want it to be complicated. I am doing a little preview here:
//Combinatorio.pas
type
ICombinatorio = interface
function getSoluzioni(): integer; //soluzioni means "Solutions"
function getFormula(): string;
end;
//ImplCombinatorio.pas
type
TCombinazioni = class(TInterfacedObject, ICombinatorio)
private
n, k: integer;
ripetizione: boolean;
function fattoriale(const x: integer): integer;
public
constructor Create(const n, k: integer; const ripetizione: boolean);
function getSoluzioni(): integer;
function getFormula(): string;
end;
TDisposizioni = class(TInterfacedObject, ICombinatorio)
private
n, k: integer;
ripetizione: boolean;
function fattoriale(const x: integer): integer;
public
constructor Create(const n, k: integer; const ripetizione: boolean);
function getSoluzioni(): integer;
function getFormula(): string;
end;
TPermutazioni = class(TInterfacedObject, ICombinatorio)
private
n: integer;
k: string;
ripetizione: boolean;
function fattoriale(const x: integer): integer;
public
constructor Create(const n: integer; const k: string; ripetizione: boolean);
function getSoluzioni(): integer;
function getFormula(): string;
end;
You don't need to see how functions and procedures are implemented, it's not important for the question (and you can easily imagine what they do).
This is my first component ever, I have compiled and installed it and it works. However I cannot understand something.
unit TCombinatorio;
interface
uses
System.SysUtils, System.Classes, Combinatorio, ImplCombinatorio;
type
cCombinatorio = (cNull = 0, cDisposition = 1, cPermutation = 2, cCombination = 3);
type
TCombinatorics = class(TComponent)
strict private
{ Private declarations }
Fn, Fk: integer;
FRep: boolean;
FType: cCombinatorio;
FEngine: ICombinatorio;
procedure Update;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
function getSolution: integer;
function getFormula: string;
published
property n: integer read Fn write Fn;
property k: integer read Fk write Fk;
property kind: cCombinatorio read FType write FType default cNull;
property repetitions: boolean read FRep write FRep;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('RaffaeleComponents', [TCombinatorics]);
end;
{ TCombinatorics }
constructor TCombinatorics.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Fn := 0;
Fk := 0;
FType := cNull;
repetitions := false;
end;
function TCombinatorics.getFormula: string;
begin
Update;
Result := FEngine.getFormula;
end;
function TCombinatorics.getSolution: integer;
begin
Update;
Result := FEngine.getSoluzioni;
end;
procedure TCombinatorics.Update;
begin
case FType of
cDisposition:
FEngine := TDisposizioni.Create(n, k, repetitions);
cPermutation:
FEngine := TPermutazioni.Create(n, '', repetitions);
cCombination:
FEngine := TCombinazioni.Create(n, k, repetitions);
cNull:
raise Exception.Create('You have to select a type.');
end;
end;
end.
Look at the Update; procedure. I have created that because when the user drops the component ( link ) in the form he has to setup in the object inspector (or with the code somewhere) 3 important parameters required in the constructor.
Since FEngine: ICombinatorio I can assign to it a class (TCombinazioni, TDisposizioni or TPermutazioni) without try finally because there is the ref count mechanism. I am not sure if I have coded this properly. Suppose that:
The user selects cDisposition and does a calculation
The user selects cDisposition (different values) and does a calculation
The user selects cPermutation and does a calculation
I am always working on the FEngine. How does the ref count go to zero? Does it go to zero when the form (and the component) destroys? I hope I have explained well what I don't understand. The FEngine is a private variable and I assing to it at runtime different classes (calling the Create). Does the ref count go to 0 when the form destroys or when a new class is assigned?
I coded it like above because nick hodges did that in his book and I trust him of course but I'd like to know what I do.
Based on the code that can be seen, the first time Update is called, a new implementor of ICombinatorio is created and assigned to FEngine; the reference count will be 1. The following times that Update is called, another new instance of ICombinatorio implementor will be created (its reference count will be 1) and is assigned to FEngine. The previous implementor instance that FEngine pointed to will have its reference count decremented; if it is zero, then it will be destroyed. (It probably will be based on your code sample).
Also, when the destructor of the component is called (when the owning Form is destroyed), the implicit instance clean-up code will set FEngine to nil, which will decrement the reference count (and, based on your sample, will be destroyed).
So, based on your code sample, I would expect your code will work properly; cleanly instanciating and destroying the ICombinatorio interfaced objects.
I have following generic class with some basic functionality and all it worked fine until one moment when I wanted to skip assigning the ConstructMethod for simple factories which just constructs the objects with .Create (without parameters or any specifics):
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;
And then I wanted to write the default constructor like:
function TGenericFactory<T, C, R>.Construct(AType: T; AParams: array of const): R;
var
Cls: C;
begin
Cls := ClassForType(AType);
if not Assigned(FConstructMethod) then
with TRttiContext.Create do
Exit((GetType(Cls) as TRttiInstanceType).MetaclassType.Create);
Result := FConstructMethod(ClassForType(AType), AParams);
end;
But... I cannot do anything like TypeInfo() or TRtiiContext.GetType() with result of ClassForType() function! The I tried other way which also fails:
function TGenericFactory<T, C, R>.Construct(AType: T; AParams: array of const): R;
var
Cls: TValue;
begin
if not Assigned(FConstructMethod) then
begin
Cls := TValue.FromVariant(ClassForType(AType));
Exit(R((TRttiContext.Create.GetType(Cls.TypeInfo) as TRttiInstanceType).MetaclassType.Create));
end;
Result := FConstructMethod(ClassForType(AType), AParams);
end;
Any ideas on how to solve this problem? For now I just do the "copy paste" for the ConstructMethod assignment like:
F := TViewFactory.Create;
F.ConstructMethod :=
function(AClass: TConfigViewClass; AParams: array of const): TConfigView
begin
if AClass = nil then
Result := nil
else
Result := AClass.Create;
end;
I still cannot instruct compiler to understand the result of ClassForType function as "class of off" (class ref) and not as "class" (instance), but I found the way how to at least call the default constructor:
function TGenericFactory<T, C, R>.Construct(AType: T; AParams: array of const): R;
var
ClsRaw: C;
Cls: TClass;
begin
if not Assigned(FConstructMethod) then
begin
ClsRaw := ClassForType(AType);
Move(ClsRaw, Cls, SizeOf(C));
Exit(R(Cls.Create));
end;
Result := FConstructMethod(ClassForType(AType), AParams);
end;
All the magic is that we just save the result of ClassForType to local variable and then copy memory to the variable of type TClass. Then we can normally call the Create!
The factory pattern (like many other patterns in the GoF book) is a workaround for a missing feature in a language (in this case the lack of virtual constructors in Java).
The way this is normally done in Delphi is this:
Create an ancestor class with a virtual constructor (can have arguments, or not).
Derive descendants that override this constructor.
Create a class of TAncestor TMetaclass.
Create instances of the descendants using the Metaclass.
Done.
An example:
type
TParent = class(TObject)
public
constructor Create; virtual; //virtual-> system resolves the actual type at runtime
end;
TParentClass = class of TParent; //Meta class
TChildA = class(TParent)
public
constructor Create; override; //Don't forget to call inherited in the body.
end;
TChildB ....
implementation
var
Input: TArray<TParentClass>;
Output: TArray<TParent>;
procedure CreateLotsOfObjects(const input: TArray<TParentClass>): TArray<TParent>;
var
X: TParentClass;
i: integer;
begin
SetLength(Result, Length(input));
i:= 0;
for X in input do begin
//because the constructor is virtual it will select the right one.
//no need for a factory pattern or reflection.
Result[i]:= X.Create;
Inc(i);
end;
end;
procedure Test;
begin
SetLength(input,200);
for i:= 0 to 199 do begin
if Odd(i) then Input[i]:= TChildA else Input[i]:= TChildB;
end;
Output:= CreateLotsOfObjects(input); //Creates 100 A's and 100 B's
end;
I want to create a TObjectList<T> descendant to handle common functionality between object lists in my app. Then I want to further descend from that new class to introduce additional functionality when needed. I cannot seem to get it working using more than 1 level of inheritance. I probably need to understand generics a little bit more, but I've search high and low for the correct way to do this without success. Here is my code so far:
unit edGenerics;
interface
uses
Generics.Collections;
type
TObjectBase = class
public
procedure SomeBaseFunction;
end;
TObjectBaseList<T: TObjectBase> = class(TObjectList<T>)
public
procedure SomeOtherBaseFunction;
end;
TIndexedObject = class(TObjectBase)
protected
FIndex: Integer;
public
property Index: Integer read FIndex write FIndex;
end;
TIndexedObjectList<T: TIndexedObject> = class(TObjectBaseList<T>)
private
function GetNextAutoIndex: Integer;
public
function Add(AObject: T): Integer;
function ItemByIndex(AIndex: Integer): T;
procedure Insert(AIndex: Integer; AObject: T);
end;
TCatalogueItem = class(TIndexedObject)
private
FID: integer;
public
property ID: integer read FId write FId;
end;
TCatalogueItemList = class(TIndexedObjectList<TCatalogueItem>)
public
function GetRowById(AId: Integer): Integer;
end;
implementation
uses
Math;
{ TObjectBase }
procedure TObjectBase.SomeBaseFunction;
begin
end;
{ TObjectBaseList<T> }
procedure TObjectBaseList<T>.SomeOtherBaseFunction;
begin
end;
{ TIndexedObjectList }
function TIndexedObjectList<T>.Add(AObject: T): Integer;
begin
AObject.Index := GetNextAutoIndex;
Result := inherited Add(AObject);
end;
procedure TIndexedObjectList<T>.Insert(AIndex: Integer; AObject: T);
begin
AObject.Index := GetNextAutoIndex;
inherited Insert(AIndex, AObject);
end;
function TIndexedObjectList<T>.ItemByIndex(AIndex: Integer): T;
var
I: Integer;
begin
Result := Default(T);
while (Count > 0) and (I < Count) and (Result = Default(T)) do
if Items[I].Index = AIndex then
Result := Items[I]
else
Inc(I);
end;
function TIndexedObjectList<T>.GetNextAutoIndex: Integer;
var
I: Integer;
begin
Result := 0;
for I := 0 to Count - 1 do
Result := Max(Result, Items[I].Index);
Inc(Result);
end;
{ TCatalogueItemList }
function TCatalogueItemList.GetRowById(AId: Integer): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to Pred(Self.Count) do
if Self.Items[I].Id = AId then
begin
Result := I;
Break;
end;
end;
end.
/////// ERROR HAPPENS HERE ////// ???? why is beyond me
It appears that the following declaration:
>>> TCatalogueItemList = class(TIndexedObjectList<TCatalogueItem>) <<<<
causes the following compiler error:
[DCC Error] edGenerics.pas(106): E2010 Incompatible types:
'TCatalogueItem' and 'TIndexedObject'
However the compiler shows the error at the END of the compiled unit (line 106), not on the declaration itself, which does not make any sense to me...
Basically the idea is that I have a generic list descending from TObjectList that I can extend with new functionality on an as needs basis. Any help with this would be GREAT!!!
I should add, using Delphi 2010.
Thanks.
Your error is in the type casting, and the compiler error is OK (but it fails to locate the correct file in my Delphi XE3).
Your ItemByIndex method is declared:
TIndexedObjectList<T>.ItemByIndex(AIndex: Integer): T;
But then you have the line:
Result := TIndexedObject(nil);
This is fine for the parent class TIndexedObjectList, where the result of the function is of type TIndexedObject, but is not OK for the descendant class TCatalogueItemList, where the result of the function is of the type TCatalogueItem.
As you may know, a TCatalogueItem instance is assignment compatible with a TIndexedObject variable, but the opposite is not true. It translates to something like this:
function TCatalogueItemList.ItemByIndex(AIndex: Integer): TCatalogueItem;
begin
Result := TIndexedObject(nil); //did you see the problem now?
To initialize the result to a nil value, you can call the Default() pseudo-function, like this:
Result := Default(T);
In Delphi XE or greater, the solution is also generic. Rather than type-casting the result as a fixed TIndexedObjectList class, you apply a generic type casting use the T type
Result := T(nil);
//or
Result := T(SomeOtherValue);
But, in this specific case, type-casting a nil constant is not needed, since nil is a special value that is assignment compatible with any reference, so you just have to replace the line with:
Result := nil;
And it will compile, and hopefully work as you expect.
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);
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;
Result := Model.Create;
should work, too.
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;
If I understand your question properly, I wrote something similar here http://www.malcolmgroves.com/blog/?p=331
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');
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.