I have next code. How to store pointers to functions Voice declared by the interface in an array?
If the abstract class TAnimal is used instead of the IVoice interface, then the pointers to the Voice function are stored in the array successfully!
PS. Delphi 10.3 Rio
type
IVoice = interface
function Voice: string;
end;
TAnimal = class abstract (TInterfacedObject)
strict private
FName: string;
public
property Name: string read FName write FName;
end;
TDog = class(TAnimal, IVoice)
protected
function Voice: string;
end;
TCat = class(TAnimal, IVoice)
protected
function Voice: string;
end;
{ TDog }
function TDog.Voice: string;
begin
Result:= 'Arf-Arf!';
end;
{ TCat }
function TCat.Voice: string;
begin
Result:= 'Meow-Meow!';
end;
var
voices: TArray<IVoice>;
funcs: TArray<TFunc<string>>;
I: Integer;
begin
voices:= [TDog.Create, TCat.Create, TDog.Create];
SetLength(funcs, Length(voices));
for I := 0 to High(voices) do
funcs[i]:= voices[i].Voice; //<--- don't compile
for I := 0 to High(funcs) do
Writeln(funcs[i]());
Readln;
end.
I expect the output
Arf-Arf!
Meow-Meow!
Arf-Arf!
but this code don't compile with error:
E2010 Incompatible types: 'System.SysUtils.TFunc<System.string>' and 'string'
You have to manually wrap the call to the interface method in an anonymous method. Like this:
funcs[i]:=
function: string
begin
Result := voices[i].Voice;
end;
Related
program Test;
{$APPTYPE CONSOLE}
uses
System.SysUtils,
System.Rtti;
function GetPropertyValue(const AObject: TObject; APropertyName: string): TValue;
var
oType: TRttiType;
oProp: TRttiProperty;
begin
oType := TRttiContext.Create.GetType(AObject.ClassType);
if oType <> nil then
begin
oProp := oType.GetProperty(APropertyName);
if oProp <> nil then
Exit(oProp.GetValue(AObject));
end;
Result := TValue.Empty;
end;
function GetAttributePropertyValue(const AClass: TClass; AAttribute: TClass;
AAttributePropertyName: string): TValue;
var
oAttr: TCustomAttribute;
begin
for oAttr in TRttiContext.Create.GetType(AClass).GetAttributes do
if oAttr.InheritsFrom(AAttribute) then
Exit(GetPropertyValue(oAttr, AAttributePropertyName));
Result := nil;
end;
function GetClassAttribute(const AClass: TClass; AAttribute: TClass): TCustomAttribute;
begin
for Result in TRttiContext.Create.GetType(AClass).GetAttributes do
if Result.InheritsFrom(AAttribute) then
Exit;
Result := nil;
end;
type
DescriptionAttribute = class(TCustomAttribute)
private
FDescription: string;
public
constructor Create(const ADescription: string);
property Description: string read FDescription;
end;
constructor DescriptionAttribute.Create(const ADescription: string);
begin
FDescription := ADescription;
end;
type
[Description('MyClass description')]
TMyClass = class(TObject);
var
oAttr: TCustomAttribute;
begin
{ ok, output is 'MyClass description' }
WriteLn(GetAttributePropertyValue(TMyClass, DescriptionAttribute, 'Description').AsString);
{ not ok, output is '' }
oAttr := GetClassAttribute(TMyClass, DescriptionAttribute);
WriteLn(DescriptionAttribute(oAttr).Description);
// WriteLn(oAttr.ClassName); // = 'DescriptionAttribute'
ReadLn;
end.
I need the rtti attribute. I was hoping to get attribute with function GetClassAttribute() but the result is not expected.
Result of function GetAttributePropertyValue() is correct (first WriteLn), but result of function GetClassAttribute() is DescriptionAttribute with empty Description value. Why?
What is correct way to get attribute as function result ?
TIA and best regards
Branko
The problem is that all RTTI related objects created during querying information (including attributes) are being destroyed if the TRttiContext goes out of scope.
You can verify this when you put a destructor on your attribute class.
Recent versions introduced KeepContext and DropContext methods on TRttiContext you can use or just put a global variable somewhere and cause it to trigger the internal creation by calling Create or something. I usually put the TRttiContext variable as class variable into the classes using RTTI.
KeepContext and DropContext can be used in code where you might not have one global TRttiContext instance that ensures its lifetime because you are using other classes, methods and routines that have their own TRttiContext reference - see for instance its use in System.Classes where during BeginGlobalLoading KeepContext is being called and in EndGlobalLoading DropContext.
I am new to Delphi Generic Classes. I don't get it of how to use the generic classes in the implementation code.
Here is the code:
Type TDataElement = class(TObject)
protected
Procedure SetName(sNewValue:String); virtual;
private
m_sName:String;
published
property sName:String read m_sName write SetName;
end;
Type TDataArray<T : TDataElement> = class(TObject)
public
function Find(dtElement:T):integer;
Procedure Add(dtElement:T);
private
m_vContainer : array of T;
protected
Function GetData(Index:integer):T; virtual;
Procedure SetData(Index:integer; NewValue:T); virtual;
public
property vData[Index: Integer]: T read GetData write SetData;
end;
implementation
function TDataArray<T>.Find(dtElement:T):integer;
var i:integer;
begin
Result:=-1;
for i := 0 to high(m_vContainer) do
if (m_vContainer[i] <> NIL)and(m_vContainer[i] = dtElement) then
begin
Result:=i;
exit;
end;
end;
.....
When I try to create instances of the Generic Classes like in the following code:
Method1)
var z:TDataArray<TDataElement>;
z:=TDataArray<TDataElement>.Create();
I get the following error:
E2010 Incompatible types: 'TDataElement' and 'class of TDataElement'
If I do this 2nd method I get another strange error:
Method 2)
type TDataElementClass = class of TDataElement;
var z:TDataArray<TDataElementClass>;
F2084 Internal Error : I8230
What I am doing wrong?
Entire source code in one file
System.SysUtils,Classes,
dtArray_unit in 'D:\VisionBot\Software\VisionBot\GUI\Units\dtArray_unit.pas';
Type TDataElement = class(TObject)
protected
Procedure SetName(sNewValue:String); virtual;
private
m_sName:String;
published
property sName:String read m_sName write SetName;
end;
Type TDataArray<T : TDataElement> = class(TObject)
public
function Find(dtElement:T):integer; overload;
Procedure Add(dtElement:T);
private
m_vContainer : array of T;
protected
Function GetData(Index:integer):T; virtual;
Procedure SetData(Index:integer; NewValue:T); virtual;
public
property vData[Index: Integer]: T read GetData write SetData;
end;
type
TDerivedDataElement = class(TDataElement)
end;
var
z2: TDataArray<TDerivedDataElement>;
//------------------------------------------------------------------------------
Procedure TDataElement.SetName(sNewValue:String);
begin
self.m_sName:=sNewValue;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
function TDataArray<T>.Find(dtElement:T):integer;
var i:integer;
begin
Result:=-1;
for i := 0 to high(m_vContainer) do
if (m_vContainer[i] <> NIL)and(m_vContainer[i] = dtElement) then
begin
Result:=i;
exit;
end;
end;
//------------------------------------------------------------------------------
Function TDataArray<T>.GetData(Index:integer):T;
begin
Result:=NIL;
if Index < 0 then exit else
if Index > high(Index) then exit else
Result:=self.m_vContainer[Index];
end;
//------------------------------------------------------------------------------
Procedure TDataArray<T>.Add(dtElement:T);
begin
SetLength(self.m_vContainer,Length(m_vContainer)+1);
m_vContainer[High(m_vContainer)]:=T;
end;
//------------------------------------------------------------------------------
Procedure TDataArray<T>.SetData(Index:integer; NewValue:T);
begin
if Index < 0 then exit else
if Index > high(Index) then exit else
self.m_vContainer[Index]:=T;
end;
//------------------------------------------------------------------------------
begin
try
z2:= TDataArray<TDerivedDataElement>.Create();
readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
var
z: TDataArray<TDataElementClass>;
The problem is that TDataElementClass is not a class derived from TDataElement.
The following would be valid:
var
z: TDataArray<TDataElement>;
Or this:
type
TDerivedDataElement = class(TDataElement)
end;
var
z: TDataArray<TDerivedDataElement>;
In your code you have
type
TDataElementClass = class of TDataElement;
Now, TDataElementClass is a metaclass.
A variable of type TDataElement can hold an instance of the type TDataElement, or an instance of any class derived from TDataElement.
A variable of type TDataElementClass can hold a type, which must be TDataElement, or any class derived from TDataElement.
You claim in the question that using TDataArray<TDataElement> leads to a compiler error, but that is not true. Consider this compiling program:
type
TDataElement = class
end;
type
TDataArray<T: TDataElement> = class
public
function Find(dtElement: T): Integer;
private
m_vContainer: array of T;
end;
function TDataArray<T>.Find(dtElement: T): Integer;
begin
for Result := 0 to high(m_vContainer) do
if (m_vContainer[Result] <> nil) and (m_vContainer[Result] = dtElement) then
exit;
Result := -1;
end;
var
arr: TDataArray<TDataElement>;
begin
arr := TDataArray<TDataElement>.Create;
end.
In your edit you show this code:
Procedure TDataArray<T>.Add(dtElement:T);
begin
SetLength(self.m_vContainer,Length(m_vContainer)+1);
m_vContainer[High(m_vContainer)]:=T;
end;
The erroneous line is here:
m_vContainer[High(m_vContainer)]:=T;
This fails because T is a type rather than an instance. I think you mean:
m_vContainer[High(m_vContainer)]:=dtElement;
is it possible to have different kind of results when declaring property in delphi class?
Example:
property month: string read monthGet(string) write monthSet(integer);
In the example, I want, with the property month, that when I :
READ, I get a string; SET, I set an integer;
The closest you can get is to use Operator Overloading but the Getter/Setter must be the same type. There is no way to change that.
program so_26672343;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
type
TMonth = record
private
FValue: Integer;
procedure SetValue( const Value: Integer );
public
class operator implicit( a: TMonth ): string;
class operator implicit( a: Integer ): TMonth;
property Value: Integer read FValue write SetValue;
end;
TFoo = class
private
FMonth: TMonth;
public
property Month: TMonth read FMonth write FMonth;
end;
{ TMonth }
class operator TMonth.implicit( a: TMonth ): string;
begin
Result := 'Month ' + IntToStr( a.Value );
end;
class operator TMonth.implicit( a: Integer ): TMonth;
begin
Result.FValue := a;
end;
procedure TMonth.SetValue( const Value: Integer );
begin
FValue := Value;
end;
procedure Main;
var
LFoo: TFoo;
LMonthInt: Integer;
LMonthStr: string;
begin
LFoo := TFoo.Create;
try
LMonthInt := 4;
LFoo.Month := LMonthInt;
LMonthStr := LFoo.Month;
finally
LFoo.Free;
end;
end;
begin
try
Main;
except
on E: Exception do
Writeln( E.ClassName, ': ', E.Message );
end;
end.
That is not possible. But properties do not have to correspond to internal storage directly, so you can do:
private
FMonth: Integer;
function GetMonthName: string;
...
property Month: Integer read FMonth write FMonth;
property MonthName: string read GetMonthName;
...
procedure TMyClass.GetMonthName: string;
begin
// code that finds name that corresponds to value of FMonth and returns it in Result.
end;
In other words, you'll have to use two properties, one write-only (or normal), one read-only.
You can't directly do that in Delphi.
What you can do is having a "casting property" like:
private
//...
intMonth: integer
//...
public
//...
property StrMonth: string read GetStrMonth write SetStrMonth;
property IntMonth: integer read intMonth write intMonth;
//...
end;
function YourClass.GetStrMonth: string;
begin
case intMonth of
1: Result := "January";
//...
end;
end;
procedure YourClass.SetStrMonth(Value: string);
begin
if StrMonth = "January" then
intMonth := 1;
//...
end;
end;
There's no way to do that for a property. A property has a single type.
The obvious way to achieve you goal is to have getter and setter functions that you use directly.
function GetMonth: string;
procedure SetMonth(Value: Integer);
You might decide to make the type part of the name to reduce confusion in the calling code. Say GetMonthStr and SetMonthOrd.
You could expose these functions as two separate properties. One read only, the other write only.
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.