In following piece of code:
type
IFoo = interface
end;
IFoo<T> = interface(IFoo)
procedure DoStuff(a: T);
end;
TFoo = class(TInterfacedObject, IFoo<Integer>, IFoo<string>, IFoo)
procedure DoStuffInt(a: Integer);
procedure DoStuffStr(a: string);
procedure IFoo<Integer>.DoStuff = DoStuffInt;
procedure IFoo<string>.DoStuff = DoStuffStr;
end;
procedure TFoo.DoStuffInt(a: Integer);
begin
Showmessage(a.ToString);
end;
procedure TFoo.DoStuffStr(a: string);
begin
ShowMessage(a);
end;
var
iint: IFoo<Integer>;
istr: IFoo<string>;
i: IFoo;
begin
i := TFoo.Create;
IFoo<integer>(i).DoStuff(123); // error
IFoo<string>(i).DoStuff('abc'); // error
end.
I want to call DoStuff methods but it doesn't work for way I did it. How cast it correctly?
Details:
Im going to have factory which will produce a IFoo instances and then i will have to cast them to concrete IFoo.
Edited:
For one interface its work fine:
type
IFoo = interface
end;
IFoo<T> = interface(IFoo)
procedure DoStuff(a: T);
end;
TFoo = class(TInterfacedObject, IFoo<integer>, IFoo)
procedure DoStuff(a: Integer);
end;
procedure TFoo.DoStuff(a: Integer);
begin
Showmessage(a.ToString);
end;
var
i: IFoo;
begin
i := TFoo.Create;
IFoo<Integer>(i).DoStuff(123);
// curiosity
IFoo<string>(i).DoStuff('abc'); // it call DoStuff(a: Integer)
Related
Suppose I have an ancestor class (TMyAncestorClass), an enumerated type (TMyType) and some descendants class (TDesc1, TDesc2, TDesc3...)
type TMytype = (ta, tb, tc);
TMyAncestorClass= class
procedure DoSomething;
end;
TDesc1 = class(TMyAncestorClass)
end;
TDesc2 = class(TMyAncestorClass)
end;
TDesc3 = class(TMyAncestorClass)
end;
function CreateMyClass(aMyType: TMyType): TMyAncestorClass;
begin
case aMyType of
ta: Result := TDesc1.Create;
tb: Result := TDesc2.Create;
tc: Result := TDesc3.Create;
else
Result := nil; // or throw an exception
end;
end;
I want to refactor it. What is the best design pattern or solution for it? Now every time a new type is added I have to modify a CreateMyClass function too.
You could get rid of the enum completely by simply having CreateMyClass() take an integer instead, eg:
unit MyClasses;
interface
type
TMyAncestorClass = class
procedure DoSomething; virtual; abstract;
end;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
implementation
type
TDesc1 = class(TMyAncestorClass)
procedure DoSomething; override;
end;
TDesc2 = class(TMyAncestorClass)
procedure DoSomething; override;
end;
TDesc3 = class(TMyAncestorClass)
procedure DoSomething; override;
end;
...
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
begin
case aMyType of
1: Result := TDesc1.Create;
2: Result := TDesc2.Create;
3: Result := TDesc3.Create;
else
Result := nil; // or throw an exception
end;
end;
end.
var
Obj: TMyAncestorClass;
begin
Obj := CreateMyClass(1, 2, 3, ...);
try
Obj.DoSomething;
finally
Obj.Free;
end;
end;
You could simplify that a little by using an array of class types, eg:
unit MyClasses;
interface
type
TMyAncestorClass = class
constructor Create; virtual; // <-- add this
procedure DoSomething; virtual; abstract;
end;
TMyAncestorClassType = class of TMyAncestorClass;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
implementation
type
TDesc1 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
TDesc2 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
TDesc3 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
...
constructor TMyAncestorClass.Create;
begin
inherited;
end;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
const
Types: array[1..3] of TMyAncestorClassType = (
TDesc1,
TDesc2,
TDesc3
);
begin
if aMyType >= Low(Types) and aMyType <= High(Types) then
Result := Types[aMyType].Create
else
Result := nil; // or throw an exception
end;
end.
var
Obj: TMyAncestorClass;
begin
Obj := CreateMyClass(1, 2, 3, ...);
try
Obj.DoSomething;
finally
Obj.Free;
end;
end;
Of course, this does mean you are still having to edit CreteMyClass() each time a new class is introduced. So, if you want something more dynamic, you will need to add a registration system at runtime, for example by storing class types in a lookup table like TDictionary, eg:
unit MyClasses;
interface
type
TMyAncestorClass = class
constructor Create; virtual;
procedure DoSomething; virtual; abstract;
end;
TMyAncestorClassType = class of TMyAncestorClass;
function RegisterMyClass(aClass: TMyAncestorClassType): Integer;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
implementation
uses
System.Generics.Collections;
var
RegisteredClasses: TDictionary<Integer, TMyAncestorClassType>;
Counter: Integer = 0;
constructor TMyAncestorClass.Create;
begin
inherited;
end;
function RegisterMyClass(aClass: TMyAncestorClassType): Integer;
begin
Result := Counter;
Inc(Counter);
RegisteredClasses.Add(Result, aClass);
end;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
var
LClass: TMyAncestorClassType;
begin
if RegisteredClasses.TryGetValue(aMyType, LClass) then
Result := LClass.Create
else
Result := nil; // or throw an exception
end;
initialization
RegisteredClasses := TDictionary<Integer, TMyAncestorClassType>.Create;
finalization
RegisteredClasses.Free;
end.
uses
..., MyClasses;
type
TDesc1 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
TDesc2 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
TDesc3 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
...
...
var
Desc1Type: Integer;
Desc2Type: Integer;
Desc3Type: Integer;
...
...
var
Obj: TMyAncestorClass;
begin
Obj := CreateMyClass(Desc1Type, Desc2Type, Desc3Type, ...);
...
Obj.Free;
end;
...
initialization
Desc1Type := RegisterMyClass(TDesc1);
Desc2Type := RegisterMyClass(TDesc2);
Desc3Type := RegisterMyClass(TDesc3);
Instead of an enumerated type, simply use the class type:
TMyType = class of TMyAncestorClass;
Then your function becomes trivial:
function CreateMyClass(aMyType: TMyType): TMyAncestorClass;
begin
Result := TMyType.Create;
end;
You call it like this:
var
X : TMyAncestroClass;
begin
X := CreateMyClass(TDesc1);
end;
Of course this is somewhat useless as is. But I guess you have a lot of other code in CreateMyClass(). BTW: I would have named it MyClassFactory.
Edit:
If you really need an enumerated type, then use the following additional code:
type
TMyTypeEnum = (ta, tb, tc);
const
MyTypes : array [TMyTypeEnum] of TMyType = (TDesc1, TDesc2, TDesc3);
The class factory is then:
function MyClassFactory(aMyType : TMyTypeEnum) : TMyAncestorClass;
begin
Result := MyTypes[aMyType].Create;
end;
And call it like this:
var
X : TMyAncestroClass;
begin
X := MyClassFactory(tb);
end;
I have class with 2 events: OnConnect and OnDisconnect:
type
TEvent = reference to procedure;
TConnection = class
private
fOnConnect: TEvent;
fOnDisconnect: TEvent;
public
procedure SomeBehavior(aChoice: Boolean);
property OnConnect: TEvent read fOnConnect write fOnConnect;
property OnDisconnect: TEvent read fOnDisconnect write fOnDisconnect;
end;
implementation
{ TConnection }
procedure TConnection.SomeBehavior(aChoice: Boolean);
begin
if aChoice then
fOnConnect
else
fOnDisconnect;
//im not cheacking Assign(Events) to make example simple
end;
now I would like to do same thing but in more object style.
I mean use interfaces and observer pattern from String4D. And i made this:
interface
uses
Spring.DesignPatterns;
type
IObserver = interface
procedure ReactToConnect(aText: String);
procedure ReactToDisconnect(aTimeoutInMs: Integer);
end;
IConnection<T> = interface(IObservable<IObserver>)
procedure SomeBehavior(aChoice: Boolean);
end;
implementation
uses
System.SysUtils;
type
TConnection = class(TObservable<IObserver>, IConnection<IObserver>)
public
procedure SomeBehavior(aChoice: Boolean);
end;
{ TConnection }
procedure TConnection.SomeBehavior(aChoice: Boolean);
var
procOnConnect: TProc<IObserver>;
procOnDisconnect: TProc<IObserver>; // what if i want no parameters?
someText: String;
someNumber: Integer;
begin
someText := RandomText;
procOnConnect := procedure(aObserver: IObserver)
begin
aObserver.ReactToConnect(someText);
end;
someNumber := RandomInt;
procOnDisconnect := procedure(aObserver: IObserver)
begin
aObserver.ReactToDisconnect(someNumber);
end;
if aChoice then
Self.NotifyListeners(procOnConnect)
else
Self.NotifyListeners(procOnDisconnect);
end;
im doing it fisrt time and just want to ask if its proper way? or im doing somethink heretical here?
I am reading Hodges book "More Coding in Delphi", section on Factory Pattern. I come up with a problem. I need to implement Init procedures for each descendant of TBaseGateway class. The problem is I do not know how to pass correct record type. Is there any nice solution?
unit Unit2;
interface
uses
Generics.Collections, System.SysUtils, System.Classes, Dialogs;
type
TGatewayTpe = (gtSwedbank, gtDNB);
type
IGateway = interface
['{07472665-54F5-4868-B4A7-D68134B9770B}']
procedure Send(const AFilesToSend: TStringList);
end;
type
TBaseGateway = class(TAggregatedObject, IGateway)
public
procedure Send(const AFilesToSend: TStringList); virtual; abstract;
end;
type
TSwedbankGateway = class(TBaseGateway)
public
// procedure Init(const ASwedbanRecord: TSwedBankRecord);
procedure Send(const AFilesToSend: TStringList); override;
end;
type
TDNBGateway = class(TBaseGateway)
public
// procedure Init(const ADNBRecord: TDNBRecord);
procedure Send(const AFilesToSend: TStringList); override;
end;
type
TGatewayFunction = reference to function: TBaseGateway;
type
TGatewayTypeAndFunction = record
GatewayType: TGatewayTpe;
GatewayFunction: TGatewayFunction;
end;
type
TGatewayFactory = class
strict private
class var FGatewayTypeAndFunctionList: TList<TGatewayTypeAndFunction>;
public
class constructor Create;
class destructor Destroy;
class procedure AddGateway(const AGatewayType: TGatewayTpe;
const AGatewayFunction: TGatewayFunction);
end;
implementation
class procedure TGatewayFactory.AddGateway(const AGatewayType: TGatewayTpe;
const AGatewayFunction: TGatewayFunction);
var
_GatewayTypeAndFunction: TGatewayTypeAndFunction;
begin
_GatewayTypeAndFunction.GatewayType := AGatewayType;
_GatewayTypeAndFunction.GatewayFunction := AGatewayFunction;
FGatewayTypeAndFunctionList.Add(_GatewayTypeAndFunction);
end;
class constructor TGatewayFactory.Create;
begin
FGatewayTypeAndFunctionList := TList<TGatewayTypeAndFunction>.Create;
end;
class destructor TGatewayFactory.Destroy;
begin
FreeAndNil(FGatewayTypeAndFunctionList);
end;
procedure TSwedbankGateway.Send(const AFilesToSend: TStringList);
begin
ShowMessage(Self.ClassName);
end;
procedure TDNBGateway.Send(const AFilesToSend: TStringList);
begin
ShowMessage(Self.ClassName);
end;
initialization
TGatewayFactory.AddGateway(gtDNB,
function: TBaseGateway
begin
Result := TDNBGateway.Create(nil);
end);
TGatewayFactory.AddGateway(gtSwedbank,
function: TBaseGateway
begin
Result := TSwedbankGateway.Create(nil);
end);
end.
Delphi support generic for IInterface. I have the follow construct using generic IInterface:
type
IVisitor<T> = interface
['{9C353AD4-6A3A-44FD-B924-39B86A4CB14D}']
procedure Visit(o: T);
end;
TMyVisitor = class(TInterfacedObject, IVisitor<TButton>, IVisitor<TEdit>)
procedure Visit(o: TButton); overload;
procedure Visit(o: TEdit); overload;
end;
implementation
procedure TMyVisitor.Visit(o: TButton);
begin
ShowMessage('Expected: TButton, Actual: ' + o.ClassName);
end;
procedure TMyVisitor.Visit(o: TEdit);
begin
ShowMessage('Expected: TEdit, Actual: ' + o.ClassName);
end;
TMyVisitor class implement two interface: IVisitor<TButton> and IVisitor<TEdit>.
I attempt invoke the methods:
procedure TForm6.Button1Click(Sender: TObject);
var V: IInterface;
begin
V := TMyVisitor.Create;
(V as IVisitor<TButton>).Visit(Button1);
(V as IVisitor<TEdit>).Visit(Edit1);
end;
The output I have is:
Expected: TEdit, Actual: TButton
Expected: TEdit, Actual: TEdit
Apparently, the code doesn't invoke procedure TMyVisitor.Visit(o: TButton) when execute (V as IVisitor<TButton>).Visit(Button1).
Is this a bug in Delphi or I should avoid implement multiple generic IInterface? All above codes have test in Delphi XE6.
as operator requires interface GUID to be able to tell which interface you are referring to. Since generic interfaces share same GUID as operator will not work with them. Basically, compiler cannot tell the difference between IVisitor<TButton> and IVisitor<TEdit> interfaces.
However, you can solve your problem using enhanced RTTI:
type
TCustomVisitor = class(TObject)
public
procedure Visit(Instance: TObject);
end;
TVisitor = class(TCustomVisitor)
public
procedure VisitButton(Instance: TButton); overload;
procedure VisitEdit(Instance: TEdit); overload;
end;
procedure TCustomVisitor.Visit(Instance: TObject);
var
Context: TRttiContext;
CurrentClass: TClass;
Params: TArray<TRttiParameter>;
ParamType: TRttiType;
SelfMethod: TRttiMethod;
s: string;
begin
Context := TRttiContext.Create;
CurrentClass := Instance.ClassType;
repeat
s := CurrentClass.ClassName;
Delete(s, 1, 1); // remove "T"
for SelfMethod in Context.GetType(Self.ClassType).GetMethods('Visit' + s) do
begin
Params := SelfMethod.GetParameters;
if (Length(Params) = 1) then
begin
ParamType := Params[0].ParamType;
if ParamType.IsInstance and (ParamType.AsInstance.MetaclassType = CurrentClass) then
begin
SelfMethod.Invoke(Self, [Instance]);
Exit;
end;
end;
end;
CurrentClass := CurrentClass.ClassParent;
until CurrentClass = nil;
end;
If you need to have Visitor interface you can change declarations to
type
IVisitor = interface
['{9C353AD4-6A3A-44FD-B924-39B86A4CB14D}']
procedure Visit(Instance: TObject);
end;
TCustomVisitor = class(TInterfacedObject, IVisitor)
public
procedure Visit(Instance: TObject);
end;
You can then use that in following manner, just by calling Visit and appropriate Visit method will be called.
procedure TForm6.Button1Click(Sender: TObject);
var V: IVisitor;
begin
V := TMyVisitor.Create;
V.Visit(Button1);
V.Visit(Edit1);
end;
Above code is based on Uwe Raabe's code and you can read more http://www.uweraabe.de/Blog/?s=visitor
And here is extended visitor interface and class that can operate on non-class types. I have implemented only calls for string, but implementation for other types consists only of copy-paste code with different typecast.
IVisitor = interface
['{9C353AD4-6A3A-44FD-B924-39B86A4CB14D}']
procedure Visit(const Instance; InstanceType: PTypeInfo);
procedure VisitObject(Instance: TObject);
end;
TCustomVisitor = class(TInterfacedObject, IVisitor)
public
procedure Visit(const Instance; InstanceType: PTypeInfo);
procedure VisitObject(Instance: TObject);
end;
procedure TCustomVisitor.Visit(const Instance; InstanceType: PTypeInfo);
var
Context: TRttiContext;
Params: TArray<TRttiParameter>;
ParamType: TRttiType;
SelfMethod: TRttiMethod;
begin
Context := TRttiContext.Create;
case InstanceType.Kind of
tkClass : VisitObject(TObject(Instance));
// template how to implement calls for non-class types
tkUString :
begin
for SelfMethod in Context.GetType(Self.ClassType).GetMethods('VisitString') do
begin
Params := SelfMethod.GetParameters;
if (Length(Params) = 1) then
begin
ParamType := Params[0].ParamType;
if ParamType.TypeKind = tkUString then
begin
SelfMethod.Invoke(Self, [string(Instance)]);
Exit;
end;
end;
end;
end;
end;
end;
procedure TCustomVisitor.VisitObject(Instance: TObject);
var
Context: TRttiContext;
CurrentClass: TClass;
Params: TArray<TRttiParameter>;
ParamType: TRttiType;
SelfMethod: TRttiMethod;
s: string;
begin
Context := TRttiContext.Create;
CurrentClass := Instance.ClassType;
repeat
s := CurrentClass.ClassName;
Delete(s, 1, 1); // remove "T"
for SelfMethod in Context.GetType(Self.ClassType).GetMethods('Visit' + s) do
begin
Params := SelfMethod.GetParameters;
if (Length(Params) = 1) then
begin
ParamType := Params[0].ParamType;
if ParamType.IsInstance and (ParamType.AsInstance.MetaclassType = CurrentClass) then
begin
SelfMethod.Invoke(Self, [Instance]);
Exit;
end;
end;
end;
CurrentClass := CurrentClass.ClassParent;
until CurrentClass = nil;
end;
Enhanced Visitor can be used like this:
TVisitor = class(TCustomVisitor)
public
procedure VisitButton(Instance: TButton); overload;
procedure VisitEdit(Instance: TEdit); overload;
procedure VisitString(Instance: string); overload;
end;
var
v: IVisitor;
s: string;
begin
s := 'this is string';
v := TVisitor.Create;
// class instances can be visited directly via VisitObject
v.VisitObject(Button1);
v.Visit(Edit1, TypeInfo(TEdit));
v.Visit(s, TypeInfo(string));
end;
This is a well known problem with generic interfaces. Here is yours:
type
IVisitor<T> = interface
['{9C353AD4-6A3A-44FD-B924-39B86A4CB14D}']
procedure Visit(o: T);
end;
Now, the as operator is implemented on top of the GUID that you specify for the interface. When you write:
(V as IVisitor<TButton>).Visit(Button1);
(V as IVisitor<TEdit>).Visit(Edit1);
how can the as operator distinguish between IVisitor<TButton> and IVisitor<TEdit>? You have only specified a single GUID. In fact when this happens, all instantiated types based on this generic interface share the same GUID. And so whilst the as operator compiles, and the code executes, the runtime behaviour is ill-defined. In effect you are defining multiple interfaces and giving them all the same GUID.
So, the fundamental issue here is that the as operator is not compatible with generic interfaces. You will have to find some other way to implement this. You might consider looking at the Spring4D project for inspiration.
Is it possible to inspect the RTTI information for an instance of a generic type with an interface type constraint? The question is probably a little ambiguous so I've created a sample console app to show what I'm trying to do:
program Project3;
{$APPTYPE CONSOLE}
uses
RTTI,
SysUtils,
TypInfo;
type
TMyAttribute = class(TCustomAttribute)
strict private
FName: string;
public
constructor Create(AName: string);
property Name: string read FName;
end;
IMyObjectBase = interface
['{E063AD44-B7F1-443C-B9FE-AEB7395B39DE}']
procedure DoSomething;
end;
TMyObjectBase = class(TInterfacedObject, IMyObjectBase)
public
procedure DoSomething; virtual;
end;
[TMyAttribute('First')]
TMyFirstRealClass = class(TMyObjectBase)
public
procedure DoSomethingDifferent;
end;
[TMyAttribute('Second')]
TMySecondRealClass = class(TMyObjectBase)
public
procedure BeSomethingDifferent;
end;
TGenericClass<I: IMyObjectBase> = class
public
function GetAttributeName(AObject: I): string;
end;
{ TMyAttribute }
constructor TMyAttribute.Create(AName: string);
begin
FName := AName;
end;
{ TMyObjectBase }
procedure TMyObjectBase.DoSomething;
begin
end;
{ TMyFirstRealClass }
procedure TMyFirstRealClass.DoSomethingDifferent;
begin
end;
{ TMySecondRealClass }
procedure TMySecondRealClass.BeSomethingDifferent;
begin
end;
{ TGenericClass<I> }
function TGenericClass<I>.GetAttributeName(AObject: I): string;
var
LContext: TRttiContext;
LProp: TRttiProperty;
LAttr: TCustomAttribute;
begin
Result := '';
LContext := TRttiContext.Create;
try
for LAttr in LContext.GetType(AObject).GetAttributes do
// ----> [DCC Error] E2250 There is no overloaded version of 'GetType' that can be called with these arguments
if LAttr is TMyAttribute then
begin
Result := TMyAttribute(LAttr).Name;
Break;
end;
finally
LContext.Free;
end;
end;
var
LFirstObject: IMyObjectBase;
LSecondObject: IMyObjectBase;
LGeneric: TGenericClass<IMyObjectBase>;
begin
try
LFirstObject := TMyFirstRealClass.Create;
LSecondObject := TMySecondRealClass.Create;
LGeneric := TGenericClass<IMyObjectBase>.Create;
Writeln(LGeneric.GetAttributeName(LFirstObject));
Writeln(LGeneric.GetAttributeName(LSecondObject));
LGeneric.Free;
LFirstObject := nil;
LSecondObject := nil;
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
I need to inspect the object being passed in (AObject), not the generic interface (I).
(Dephi 2010).
Thanks for any advice.
Two possible solutions for this is as follows:
1) I tested with this and it works (XE4):
for LAttr in LContext.GetType((AObject as TObject).ClassType).GetAttributes do
2) I tested with this and it works (XE4):
for LAttr in LContext.GetType(TMyObjectBase(AObject).ClassType).GetAttributes do
3) Create method on the interface that returns the object and use that to inspect the object:
IMyObjectBase = interface
['{E063AD44-B7F1-443C-B9FE-AEB7395B39DE}']
procedure DoSomething;
function GetObject: TObject;
end;
TMyObjectBase = class(TInterfacedObject, IMyObjectBase)
public
procedure DoSomething; virtual;
function GetObject: TObject;
end;
{ TMyObjectBase }
function TMyObjectBase.GetObject: TObject;
begin
Result := Self;
end;
And then call it like this:
for LAttr in LContext.GetType(AObject.GetObject.ClassType).GetAttributes do