I am trying to write a spec utility library.
One of the Specification is a TExpressionSpecification. Basically, it implements the Specification pattern by evaluating an inner TExpression.
One of the TExpression is a TPropertyExpression. It's simply an expression that gets the value of a property by its name with Rtti.
I implemented it the simplest way I could, but really cannot understand why it throws an AV at me.
I stepped throrouly with the debugger. All types are what they are supposed to be. I just dont know why the TRttiProperty.GetValue is wrecking havoc.
Can anybody help?
unit Spec;
interface
uses
Classes;
type
TPropertyExpression<TObjectType, TResultType> = class
private
FPropertyName: string;
public
constructor Create(aPropertyName: string); reintroduce;
function Evaluate(aObject: TObjectType): TResultType;
property PropertyName: string read FPropertyName write FPropertyName;
end;
procedure TestIt;
implementation
uses
Rtti;
constructor TPropertyExpression<TObjectType, TResultType>.Create(aPropertyName:
string);
begin
inherited Create;
PropertyName := aPropertyName;
end;
function TPropertyExpression<TObjectType, TResultType>.Evaluate(aObject:
TObjectType): TResultType;
var
aCtx : TRttiContext;
aModelType : TRttiType;
aResultType : TRttiType;
aProperty : TRttiProperty;
aValue : TValue;
begin
aCtx := TRttiContext.Create;
aModelType := aCtx.GetType(System.TypeInfo(TObjectType));
aResultType := aCtx.GetType(System.TypeInfo(TResultType));
aProperty := aModelType.GetProperty(PropertyName);
aValue := aProperty.GetValue(Addr(aObject));
Result := aValue.AsType<TResultType>;
end;
procedure TestIt;
var
aComponent : TComponent;
aSpec : TPropertyExpression<TComponent, string>;
begin
aComponent := TComponent.Create(nil);
aComponent.Name := 'ABC';
aSpec := TPropertyExpression<TComponent, string>.Create('Name');
WriteLn(aSpec.Evaluate(aComponent));
Readln;
end;
end.
GetValue expects the instance pointer (aObject) but you are passing it the address of the pointer variable (#aObject).
Constrain your TObjectType to a class type:
type
TPropertyExpression<TObjectType: class; TResultType> = class...
Then, instead of Addr(aObject), pass the instance directly:
aValue := aProperty.GetValue(Pointer(aObject));
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.
SITUATION. I have created an unit with some classes to solve algebra stuff (congruences and systems), I am showing you the code:
type
TCongrError = class(Exception)
end;
type
TCongruence = class(TComponent)
//code stuff
constructor Create(a, b, n: integer); virtual;
end;
type
TCongrSystem = array of TCongruence;
type
TCongruenceSystem = class(TThread)
private
resInner: integer;
FData: TCongrSystem;
function modinv(u, v: integer): integer; //not relevant
protected
procedure Execute; override;
public
constructor Create(data: TCongrSystem; var result: integer; hasClass: boolean);
end;
I have decided to use TThread because this class has an Execute method that could take some time to finish due to the length of the parameters passed to the constructor. Here's the implementation:
constructor TCongruenceSystem.Create(data: TCongrSystem; var result: integer; hasClass: boolean);
begin
inherited Create(True);
FreeOnTerminate := true;
FData := data;
setClass := hasClass;
resInner := result;
end;
procedure TCongruenceSystem.Execute;
var sysResult, i, n, t: integer;
begin
sysResult := 0;
n := 1;
//computation
Queue( procedure
begin
ShowMessage('r = ' + sysResult.ToString);
resInner := sysResult;
end );
end;
PROBLEM
If you look at the Queue you see that I am using (just as test) the ShowMessage and it is showing the correct value of sysResult. The second line by the way has some problems that I cannot understand.
The constructor has var result: integer so I can have side-effect from the passed variable and then I can assign resInner := result;. At the end (in the Queue) I am giving resInner the value of sysResult and I expect result to be updated too due to the side effect of var. Why doesn't this happen?
I have made another test changing the constructor like this:
constructor TCongruenceSystem.Create(data: TCongrSystem; result: TMemo; hasClass: boolean);
//now of course I have resInner: TMemo
And changing the Queue to this:
Queue( procedure
begin
ShowMessage('r = ' + sysResult.ToString);
resInner.Lines.Add(sysResult.ToString);
end ); //this code now works properly in both cases! (showmessage and memo)
In the constructor I am passing TMemo which is a reference and ok, but isn't the original var result: integer passed as reference too? Why then it doesn't work?
I want to do this because I'd like to do something like this:
//I put var a: integer; inside the public part of the TForm
test := TCongruenceSystem.Create(..., a, true);
test.OnTerminate := giveMeSolution;
test.Start;
test := nil;
Where giveMeSolution is just a simple procedure that uses the variable a containing the result of the system. If this is not possible what could I do? Basically the result at the end of Execute is just an integer number that has to be passed to the main thread.
I have read about ReturnValue but I am not sure how to use it.
Basically the result at the end of Execute is just an integer number that has to be passed to the main thread.
I have read about ReturnValue but I am not sure how to use it.
Using the ReturnValue property is very easy:
type
TCongruenceSystem = class(TThread)
...
protected
procedure Execute; override;
public
property ReturnValue; // protected by default
end;
procedure TCongruenceSystem.Execute;
var
...
begin
// computation
ReturnValue := ...;
end;
test := TCongruenceSystem.Create(...);
test.OnTerminate := giveMeSolution;
test.Start;
....
procedure TMyForm.giveMeSolution(Sender: TObject);
var
Result: Integer;
begin
Result := TCongruenceSystem(Sender).ReturnValue;
...
end;
Let's assume a class field FFoo : integer; ;
procedure TFoo.Foo(var x : integer);
begin
FFoo := x;
end;
Here what you are doing is assigning the value of x to FFoo. Inside the method Foo you are free to modify the value of the variable passed in as x but integers are otherwise value types that are copied on assignment. If you want to keep a reference to an external integer variable you would need to declare FFoo (or, in your case, resInner) as a PInteger (pointer to an integer). For example (simplifying) :
TCongruenceSystem = class(TThread)
private
resInner: PInteger;
protected
procedure Execute; override;
public
constructor Create(result: PInteger);
end;
where
constructor TCongruenceSystem.Create(result: PInteger);
begin
inherited Create(True);
FreeOnTerminate := true;
resInner := result;
end;
which you would call as test := TCongruenceSystem.Create(#a); and assign:
{ ** See the bottom of this answer for why NOT to use }
{ Queue with FreeOnTerminate = true ** }
Queue( procedure
begin
ShowMessage('r = ' + sysResult.ToString);
resInner^ := sysResult;
end );
The reason it works with TMemo is that classes are reference types - their variables do not hold values but rather point to the address of the object in memory. When you copy a class variable you are only copying a reference (ie: a pointer) whereas for value types the contents of the variable are copied on assignment.
With that said, there's nothing stopping you from keeping the argument typed as var x : integer and taking a reference in your constructor :
constructor TCongruenceSystem.Create(var result: Integer);
begin
inherited Create(True);
FreeOnTerminate := true;
resInner := #result; {take the reference here}
end;
but this gives the caller the impression that once the constructor is complete that you have made any modifications to the variable you intend to and they are free to dispose of the integer. Passing explicitly as PInteger gives the caller a hint that your object will keep a reference to the integer they provide and that need to ensure the underlying variable remains valid while your class is alive.
And... with all that said, I still fundamentally don't like this idea. By taking in a variable reference like this you are offloading an atypical lifetime management issue to the caller. Passing pointers is best done in place where they are used at the point of transfer only. Holding onto a foreign pointer is messy and it's too easy for mistakes to happen. A far better approach here would be to provide a completion event and have the consumer of your class attach a handler.
For example :
{ define a suitable callback signature }
TOnCalcComplete = procedure(AResult : integer) of object;
TCongruenceSystem = class(TThread)
private
Fx, Fy : integer;
FOnCalcComplete : TOnCalcComplete;
protected
procedure Execute; override;
public
constructor Create(x,y: integer);
property OnCalcComplete : TOnCalcComplete read FOnCalcComplete write FOnCalcComplete;
end;
constructor TCongruenceSystem.Create(x: Integer; y: Integer);
begin
inherited Create(true);
FreeOnTerminate := true;
Fx := x;
Fy := y;
end;
procedure TCongruenceSystem.Execute;
var
sumOfxy : integer;
begin
sumOfxy := Fx + Fy;
sleep(3000); {take some time...}
if Assigned(FOnCalcComplete) then
Synchronize(procedure
begin
FOnCalcComplete(sumOfxy);
end);
end;
Which you would then call as :
{ implement an event handler ... }
procedure TForm1.CalcComplete(AResult: Integer);
begin
ShowMessage(IntToStr(AResult));
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LCongruenceSystem : TCongruenceSystem;
begin
LCongruenceSystem := TCongruenceSystem.Create(5, 2);
LCongruenceSystem.OnCalcComplete := CalcComplete; { attach the handler }
LCongruenceSystem.Start;
end;
You'll also notice that I used Synchronize here instead of Queue. On this topic, please have a read of this question (I'll quote Remy...):
Ensure all TThread.Queue methods complete before thread self-destructs
Setting FreeOnTerminate := True in a queued method is asking for a memory leak.
I am using RemObjects DataAbstract along with Spring4d. RemObjects generates a SchemaServer_Intf.pas file that contains interfaces for every kind of table that exists in it's schema. It allows for "Strongly typed" datasets, allowing one to access a field using
(aDataSet as IMyDataSet).MyField := aValue
Here is a snapshot of one of the interfaces generated by DataAbstract
IEntiteType = interface(IDAStronglyTypedDataTable)
['{96B82FF7-D087-403C-821A-0323034B4B99}']
{ Property getters and setters }
function GetEntiteIdValue: String;
procedure SetEntiteIdValue(const aValue: String);
function GetEntiteIdIsNull: Boolean;
procedure SetEntiteIdIsNull(const aValue: Boolean);
function GetNameValue: WideString;
procedure SetNameValue(const aValue: WideString);
function GetNameIsNull: Boolean;
procedure SetNameIsNull(const aValue: Boolean);
function GetIsSystemValue: SmallInt;
procedure SetIsSystemValue(const aValue: SmallInt);
function GetIsSystemIsNull: Boolean;
procedure SetIsSystemIsNull(const aValue: Boolean);
{ Properties }
property EntiteId: String read GetEntiteIdValue write SetEntiteIdValue;
property EntiteIdIsNull: Boolean read GetEntiteIdIsNull write SetEntiteIdIsNull;
property Name: WideString read GetNameValue write SetNameValue;
property NameIsNull: Boolean read GetNameIsNull write SetNameIsNull;
property IsSystem: SmallInt read GetIsSystemValue write SetIsSystemValue;
property IsSystemIsNull: Boolean read GetIsSystemIsNull write SetIsSystemIsNull;
end;
Though, there is one problem. If you cast a dataTable like so:
aDataTable := IEntiteType(TDAMemDataTable.Create(nil));
You'll have an "Interface not supported error"
But, as soon as you do:
aDataTable.LogicalName := 'EntiteType';
aDataTable.BusinessRulesId := MyBusinessRuleID;
You can safely write
aDataTable := IEntiteType(TDAMemDataTable.Create(nil));
And you don't get any error.
So, with Spring4d, I thought of writing this in my registration unit:
aContainer.RegisterType<TDAMemDataTable>.Implements<IEntiteType>.DelegateTo(
function : TDAMemDataTable
var aDataTable : TDAMemDataTable;
begin
Result:= TDAMemDataTable.Create(nil);
Result.LogicalName := 'EntiteType';
Result.BusinessRulesId := MyBusinessRuleId;
end
)
But then, Spring4d throws (with reason) error :
Exception 'first chance' à $762D5B68. Classe d'exception ERegistrationException avec un message 'Component type "uDAMemDataTable.TDAMemDataTable" incompatible with service type "SchemaClient_Intf.IEntiteType".'. Processus EntiteREM2.exe (3088)
Is there a way to override this check?
Ok I've found a way to do that. Super simple actually :
aContainer.RegisterType<IAddress>.DelegateTo(
function : IAddress
var aTable : TDAMemDataTable;
begin
aTable := TDAMemDataTable.Create(nil);
aTable.LogicalName := nme_Address;
aTable.BusinessRulesID := RID_Address;
Result := aTable as IAddress;
end
);
Also, for people interested in registering many tables in an elegant fashion :
aContainer.RegisterType<IAddress>.DelegateTo(TableConfigurator.GetTableDelegate<IAddress>(nme_Address, RID_Address));
// Registering other tables here...
Just create some "Helper" class with this method :
class function TableConfigurator.GetTableDelegate<T>(aLogicalName, aBusinessRulesId: string): TActivatorDelegate<T>;
begin
Result := (function: T
var
aTable: TDAMemDataTable;
begin
aTable := TDAMemDataTable.Create(nil);
aTable.LogicalName := aLogicalName;
aTable.BusinessRulesID := aBusinessRulesId;
Result := T(TValue.From(aTable).AsInterface);
end);
end;
I have unconstrained generic type Atomic which implements an initializer (details in my previous question).
type
Atomic<T> = class
type TFactory = reference to function: T;
class function Initialize(var storage: T; factory: TFactory): T;
end;
Now I want to write simplified Initialize function which would take the type information from T (provided that typeof(T) is tkClass) and create new instance (when necessary) with the default constructor.
Sadly, this fails:
class function Atomic<T>.Initialize(var storage: T): T;
begin
if not assigned(PPointer(#storage)^) then begin
if PTypeInfo(TypeInfo(T))^.Kind <> tkClass then
raise Exception.Create('Atomic<T>.Initialize: Unsupported type');
Result := Atomic<T>.Initialize(storage,
function: T
begin
Result := TClass(T).Create; // <-- E2571
end);
end;
end;
Compiler reports error E2571 Type parameter 'T' doesn't have class or interface constraint.
How can I trick the compiler to create an instance of class T?
You can use GetTypeData to obtain the class reference:
Result := T(GetTypeData(PTypeInfo(TypeInfo(T)))^.ClassType.Create);
In Delphi XE2 (and hopefully in next releases), you can do:
var
xInValue, xOutValue: TValue;
xInValue := GetTypeData(PTypeInfo(TypeInfo(T)))^.ClassType.Create;
xInValue.TryCast(TypeInfo(T), xOutValue);
Result := xOutValue.AsType<T>;
(This rather circumvent way was discovered by used cjsalamon in the OmniThreadLibrary forum: Error in OtlSync XE2.)
You can use the new Delphi Rtti to make this task. The drawback of given solution is that it won't work if the constructor isn't named as Create. If you need to make it work all the time, just enumerate your type methods, check if it's a constructor and have 0 parameters and then invoke it. Works in Delphi XE. Sample code:
class function TTest.CreateInstance<T>: T;
var
AValue: TValue;
ctx: TRttiContext;
rType: TRttiType;
AMethCreate: TRttiMethod;
instanceType: TRttiInstanceType;
begin
ctx := TRttiContext.Create;
rType := ctx.GetType(TypeInfo(T));
AMethCreate := rType.GetMethod('Create');
if Assigned(AMethCreate) and rType.IsInstance then
begin
instanceType := rType.AsInstance;
AValue := AMethCreate.Invoke(instanceType.MetaclassType, []);// create parameters
Result := AValue.AsType<T>;
end;
end;
Updated solution:
class function TTest.CreateInstance<T>: T;
var
AValue: TValue;
ctx: TRttiContext;
rType: TRttiType;
AMethCreate: TRttiMethod;
instanceType: TRttiInstanceType;
begin
ctx := TRttiContext.Create;
rType := ctx.GetType(TypeInfo(T));
for AMethCreate in rType.GetMethods do
begin
if (AMethCreate.IsConstructor) and (Length(AMethCreate.GetParameters) = 0) then
begin
instanceType := rType.AsInstance;
AValue := AMethCreate.Invoke(instanceType.MetaclassType, []);
Result := AValue.AsType<T>;
Exit;
end;
end;
end;
And call it like this:
var
obj: TTestObj;
begin
obj := TTest.CreateType<TTestObj>;
If I got it right, the generic type "T" is a class. In this case, just declare:
Atomic< T: class > = class
instead of the flat
Atomic< T > = class
This will tell to the compiler that T is a class type, so you'll be able to use the constructor and all the other features of class type without any extra workaround.
If my understanding was wrong in the base assumption, I apologize.
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.