i have a base class and 10 class derived from that class. Base class contain a function that except parameter of type procedure of object. like this
mytype = procedure (a : integer) of object;
baseclass = class
public
procedure myproc(cont handler : mytype ) ;
end;
procedure baseclass.myproc(cont handler : mytype ) ;
begin
// do something
end;
i am overloading this function in derived class i.e derived class contain same function but with different parameter (procedure ( const handler : integer ) of object ). like this
base1mytype = procedure (a : string) of object;
derivedclass1 = class(baseclass)
public
procedure myproc(cont handler : base1mytype ) ;overload;
end;
base2mytype = procedure (a : boolean) of object;
derivedclass1 = class(baseclass)
public
procedure myproc(cont handler : base2mytype ) ;overload;
end;
and so on.........
All i want a generic class that implement this function and i derive my classes from that function eg
mytype = procedure (a : integer) of object;
baseclass<T> = class
public
procedure myproc(cont handler : T) ;
end;
procedure baseclass<T>.myproc(cont handler : T ) ;
begin
// do something
end;
and derive classes are like this
deriveclass1 = class<baseclass <string>>
public
procedure myproc(cont handler : T) ;
end;
Since generic constraint does not support constrain of type procedure of object
You need a generic class with an internal type definition:
type
TBaseClass<T> = class
public
type
THandler = procedure(Arg: T) of object;
public
procedure CallHandler(Handler: THandler; Arg: T);
end;
procedure TBaseClass<T>.CallHandler(Handler: THandler; Arg: T);
begin
Handler(Arg);
end;
Related
There are two objects: TFoo, TFoo2.
There is also a class reference : TFooClass = class of TFoo;
Both are descendants from TPersistent.
They have their own constructors:
type
TFoo = class(TPersistent)
private
FC:Char;
public
constructor Create; virtual;
published
property C:Char read FC write FC;
end;
TFoo2 = class(TFoo)
public
constructor Create; override;
end;
TFooClass = class of TFoo;
...
constructor TFoo.Create;
begin
inherited Create;
C :=' 1';
end;
constructor TFoo2.Create;
begin
inherited Create;
C := '2';
end;
I want to create a TFoo2 object from a string, which is actually its class name : 'TFoo2'
Here is the procedure, which works fine:
procedure Conjure(AClassName:string);
var
PClass : TPersistentClass;
p :TPersistent;
begin
PClass := TPersistentClass(FindClass(AClassName))
p := TFooClass(PClass).Create; // <-- here is called appropriate constructor
end;
Now, I want to have similar objects like: TBobodo, TBobodo2.
And a class reference of course : TBobodoClass = class of TBobodo;
And so on...
Now, how can I pass a class reference as a parameter into a procedure, in order to secure the right constructor is called?
procedure Conjure(AClassName:string; ACLSREF: ???? ); // <-- something like that
var
PClass : TPersistentClass;
p :TPersistent;
begin
PClass := TPersistentClass(FindClass(AClassName))
p := ACLSREF(PClass).Create; // <-- something like that
end;
Is it possible?
There is no way to do what you want in Delphi 7. The metaclass reference has to be explicit at compile-time at the call site, not handled at runtime.
In Delphi 2009 and later, you may 1 be able to do something with Generics, eg:
1: I have not tried this myself yet.
type
TConjureHelper = class
public
class procedure Conjure<TClassType>(const AClassName: string);
end;
class procedure TConjureHelper.Conjure<TClassType>(const AClassName: string);
var
PClass : TPersistentClass;
p : TPersistent;
begin
PClass := TPersistentClass(FindClass(AClassName));
p := TClassType(PClass).Create;
...
end;
...
TConjureHelper.Conjure<TFooClass>('TFoo2');
TConjureHelper.Conjure<TBobodoClass>('TBobodo2');
...
But Delphi 7 certainly does not support Generics.
I had the same problem and after some struggles, I found a quite simple solution: metaclass is invented exactly for this purpose!
In your case, you can pass the metaclass as parameter and use it directly without the cumbersome finding class and type casting.
type
TFooClass = class of TFoo;
procedure Conjure(aFooClass : TFooClass); // <-- something like that
var
p :TPersistent;
begin
p := aFooClass.Create; // it will work!
end;
and by calling, you simply use:
Conjure(TFoo); // <- for Foo class or
Conjure(TFoo2); // <- for Foo2 class and so on
Howdey,
I am using TVirtualInterface to implement some interfaces. Those interfaes represent Keys that can be found in a DB. I generate the interface definitions with a custom made code generator. For example :
// Base code
IKey = interface
function KeyFields : string;
function KeyValues : Variant;
function GetKeyValue(const aKeyName : string) : Variant;
procedure SetKeyValue(const aKeyName : string; Value : Variant);
end;
// Generated code
ITable1Key = interface(IKey)
end;
ITable1Key1 = interface(ITable1Key)
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
end;
ITable1Key2 = interface(ITable1Key)
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
procedure SetField2(const Value : string);
function GetField2 : string;
property Field2 : string read GetField1 write SetField1;
end;
// Other generated declarations
I use the TVirtualInterface to implement each IKey interface instead of implementing them one by one.
Though, in my TVirtualInterface :
TKey = TVirtualInterface
public
constructor Create(aType : PTypeInfo);
function Cast : IKey;
end;
TKey<T : IKey>
public
constructor Create; reintroduce;
function Cast : T;
end;
constructor TKey.Create(aType : PTypeInfo)
begin
inherited Create(aType, aHandlerMethod);
end;
function TKey.Cast;
var
pInfo: PTypeInfo;
begin
pInfo := TypeInfo(IKey);
if QueryInterface(GetTypeData(pInfo).Guid, Result) <> 0 then
begin
raise Exception.CreateFmt('Sorry, TKey is unable to cast %s to its interface ', [string(pInfo.Name)]);
end;
end;
constructor TKey<T>.Create;
begin
inherited Create(TypeInfo(T));
end;
function TKey<T>.Cast;
var
pInfo: PTypeInfo;
begin
pInfo := TypeInfo(T);
if QueryInterface(GetTypeData(pInfo).Guid, Result) <> 0 then
begin
raise Exception.CreateFmt('Sorry, TKey<T> is unable to cast %s to its interface ', [string(pInfo.Name)]);
end;
end;
I have no problem casting the TKey virtual interface to the T type using the TKey.Cast method, though TKey.Cast returns a Interface not supported error.
I checked in System.Rtti for the part that wasn't working the way I wanted it to :
function TVirtualInterface.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if iid = FIID then
begin
_AddRef;
Pointer(Obj) := #VTable;
Result := S_OK;
end
else
Result := inherited
end;
Now, how can I force the TVirtualInterface to cast itself to a IID that is a parent interface of the FIID field ? Do I have to create another instance of the TVirtualInterface for the IKey interface ?
Thank you very much.
You are misusing TVirtualInterface. It is just an RTTI helper, you should not be deriving from it at all. You should be deriving from TInterfacedObject instead.
Also, both of your TKey classes are ignoring the PTypeInfo that is passed to the constructor. The non-Generic TKey.Cast() is always querying for IKey only, never a descendant interface. And the Generic TKey<T>.Cast is always re-querying T's RTTI to get its IID. So get rid of the PTypeInfo in the constructor, it is wasted.
Since the non-Generic TKey is just a base class that doesn't actually implement any derived interfaces at all, TKey.QueryInterface() will always fail for any interface other than IKey itself. At least the Generic TKey can query a derived interface.
Your Cast functions are redundant anyway, since you can use the as operator, or the SysUtils.Supports() function, to cast one interface to another. These are the preferred methods, not using QueryInterface() manually.
In any case, your interfaces are missing IIDs in their declarations, so you can't cast between interfaces anyway.
Try something more like this:
// Base code
IKey = interface
['{D6D212E0-C173-468C-8267-962CFC3FECF5}']
function KeyFields : string;
function KeyValues : Variant;
function GetKeyValue(const aKeyName : string) : Variant;
procedure SetKeyValue(const aKeyName : string; Value : Variant);
end;
// Generated code
ITable1Key = interface(IKey)
['{B8E44C43-7248-442C-AE1B-6B9E426372C1}']
end;
ITable1Key1 = interface(ITable1Key)
['{0C86ECAA-A8E7-49EB-834F-77DE62BE1D28}']
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
end;
ITable1Key2 = interface(ITable1Key)
['{82226DE9-221C-4268-B971-CD72617C19C7}']
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
procedure SetField2(const Value : string);
function GetField2 : string;
property Field2 : string read GetField1 write SetField1;
end;
// Other generated declarations
type
TKey = class(TInterfacedObject, IKey)
public
function Cast : IKey;
// IKey methods...
end;
TKey<T : IKey> = class(TInterfacedObject, IKey, T)
public
function Cast : T;
end;
TTable1Key = class(TKey, IKey, ITable1Key)
end;
TTable1Key1 = class(TTable1Key, IKey, ITable1Key, ITable1Key1)
public
// ITable1Key1 methods...
end;
TTable1Key2 = class(TTable1Key, IKey, ITable1Key, ITable1Key2)
public
// Table1Key2 methods...
end;
// and so on ...
function TKey.Cast: IKey;
begin
if not Supports(Self, IKey, Result) then
raise Exception.Create('Sorry, unable to cast to IKey');
end;
function TKey<T>.Cast: T;
begin
if not Supports(Self, GetTypeData(TypeInfo(T)).Guid, Result) then
raise Exception.CreateFmt('Sorry, unable to cast to %s', [string(TypeInfo(T).Name)]);
end;
// other class methods as needed ...
Also note how the derived classes have to repeat the interfaces implemented by their base classes. That is a known Delphi limitation. Derived classes do not inherit base class interfaces. Each class has to explicitly specify the interfaces it implements, even if the actual implementation is in a base class.
In Delphi 10 Seattle I want to make TProject class with structure like this:
// TProject
// Frames[]:TFrame -- all frames in project folder
// Sounds[]:TSound -- all sounds in project folder
// WorkSets[]:TWorkSet -- frames subsets for some kind of works
// WorkSetFrames[]:TWorkSetFrame
// Clips[]:TClip -- recorded clips
// ClipFrames[]:TClipFrame
and I want to have not only forward link from project to a collection and from collection to item. Also, I want to have backlinks from each final item to their owned collection and from each collection to their owner object.
Main request - all links must be correctly typed:
TProject.Clips must be type TClipCollection, derived from that basic generic collection class;
TClip must be also derived from that basic generic collection item class.
TClipCollection.Owner must be TProject
TClip.OwnerCollection must be TClipCollection
It must fill by constructors and obtain it from that basic generic classes.
And next - it must be overridable, to allow me to add property Name to generic collection item descendant and FindByName function to generic collection class and obtain a possibility to instantiate some of my collections from this two new generic classes. For example, to make TFrame and TFrameCollection with this feature.
It can be based on TCollection or TList, but it all don't have all the required features.
I have tried some declarations, but it led to class incompatibility errors (https://en.wikipedia.org/wiki/Covariance_and_contravariance_%28computer_science%29 problem noted in explanations).
UPD 1:
The last attempt to solve the problem of usage generic collection and generic collection item classes which use each other and allow override it led me to this code:
unit GenericCollection;
interface
uses Generics.Collections;
type
TGenericCollectionItem<TCollectionOwner: class> = class
public
type
TCollection = class(TList<TGenericCollectionItem<TCollectionOwner>>)
private
FOwner: TCollectionOwner;
public
property Owner: TCollectionOwner read FOwner;
constructor Create(AOwner: TCollectionOwner);
end;
private
FOwnerCollection: TCollection;
function GetIndex: Integer;
procedure SetIndex(const Value: Integer);
public
property Index: Integer read GetIndex write SetIndex;
property OwnerCollection: TCollection read FOwnerCollection;
end;
TNamedGenericCollectionItem<TCollectionOwner: class> = class(TGenericCollectionItem<TCollectionOwner>)
public
type
TNamedGenericCollection = class(TCollection)
public
function FindItemName(AName: string): TNamedGenericCollectionItem<TCollectionOwner>;
end;
private
FName: string;
public
property Name: string read FName write FName;
end;
implementation
{ TGenericCollectionItem<ACollectionOwnerType> }
function TGenericCollectionItem<TCollectionOwner>.GetIndex: Integer;
begin
Result := OwnerCollection.IndexOf(Self);
end;
procedure TGenericCollectionItem<TCollectionOwner>.SetIndex(
const Value: Integer);
var
CurIndex: Integer;
begin
CurIndex := GetIndex;
if (CurIndex >= 0) and (CurIndex <> Value) then
FOwnerCollection.Move(CurIndex, Value);
end;
{ TGenericCollectionItem<ACollectionOwnerType>.TCollection }
constructor TGenericCollectionItem<TCollectionOwner>.TCollection.Create(
AOwner: TCollectionOwner);
begin
inherited Create;
FOwner := AOwner;
end;
{ TNamedGenericCollectionItem<TCollectionOwner>.TNamedGenericCollection }
function TNamedGenericCollectionItem<TCollectionOwner>.TNamedGenericCollection.FindItemName(
AName: string): TNamedGenericCollectionItem<TCollectionOwner>;
var
X: TGenericCollectionItem<TCollectionOwner>;
begin
// TODO: Use hash-based index
for X in Self do
if TNamedGenericCollectionItem<TCollectionOwner>(X).Name = AName then
Exit(TNamedGenericCollectionItem<TCollectionOwner>(X));
end;
end.
But when I use it by declaring
TFrame = class(TNamedGenericCollectionItem<TProject>)
end;
and adding to TProject
FFrames: TFrame.TNamedGenericCollection;
this call in TProject's constructor
FFrames := TFrame.TNamedGenericCollection.Create(Self);
still geave me annoying exception:
[dcc32 Error] ProjectInfo.pas(109): E2010 Incompatible types:
'TNamedGenericCollectionItem<TCollectionOwner>.TNamedGenericCollection' and
'GenericCollection.TNamedGenericCollectionItem<ProjectInfo.TProject>.TNamedGenericCollection'
What I can do to solve this?
I really think that you are over-thinking this. Once I got my head round what you are trying to do, you just want the owner to know what sort its items are (which TObjectList< T > for example already knows) and for the item to know what its owner is, which is easily constructed.
unit Unitgenerics;
interface
uses
System.Generics.Collections;
type
TGItem<TOwner : class> = class
private
fOwner: TOwner;
public
constructor Create( const pOwner : TOwner );
property Owner : TOwner
read fOwner;
end;
TRealItem = class;
TRealOwner = class( TObjectList<TRealItem> )
// Items are already of type TRealItem
end;
TRealItem = class(TGItem< TRealOwner > )
// Owner already defined and is of type TRealOwner
end;
implementation
{ TGItem<TOwner> }
constructor TGItem<TOwner>.Create(const pOwner: TOwner);
begin
inherited Create;
fOwner := pOwner;
end;
end.
To extend this down to descendants, that is easy enough for the items if the owner didn't change. But it does. However all we need to do is use generics to reflect to the descendants how the owner changes - like this
unit Unitgenerics;
interface
uses
System.Generics.Collections;
type
TGItem<TOwner : class> = class
private
fOwner: TOwner;
public
constructor Create( const pOwner : TOwner );
property Owner : TOwner
read fOwner;
end;
TRealItem< TOwner : class > = class;
TRealOwner<TOwner : class> = class( TObjectList<TRealItem< TOwner >> )
// Items are already of type TRealItem<TOwner>
end;
TRealItem< TOwner : class > = class(TGItem< TRealOwner<TOwner> > )
// Owner already defined and is of type TRealOwner<TOwner>
end;
implementation
{ TGItem<TOwner> }
constructor TGItem<TOwner>.Create(const pOwner: TOwner);
begin
inherited Create;
fOwner := pOwner;
end;
end.
This is how to extend further without nesting generics too far...
unit Unitgenerics;
interface
uses
System.Generics.Collections;
type
TGItem<TOwner : class> = class
private
fOwner: TOwner;
public
constructor Create( const pOwner : TOwner );
property Owner : TOwner
read fOwner;
end;
TRealItem< TOwner : class > = class;
TRealOwner<TOwner : class> = class( TObjectList<TRealItem< TOwner >> )
// Items are already of type TRealItem
// add some properties here
end;
TRealItem< TOwner : class > = class(TGItem< TRealOwner<TOwner> > )
// Owner already defined and is of type TRealOwner
// add some properties here
end;
T2ndLevelItem = class;
T2ndLevelOwner = class;
T2ndLevelOwner = class( TRealOwner< T2ndLevelOwner > )
end;
T2ndLevelItem = class( TRealItem< T2ndLevelOwner > )
end;
TInheritable2ndLevelItem< TOwner : class> = class;
TInheritable2ndLevelOwner< TOwner : class> = class;
TInheritable2ndLevelOwner< TOwner : class> = class( TRealOwner< TOwner > )
end;
TInheritable2ndLevelItem< TOwner : class> = class( TRealItem< TOwner > )
end;
T3rdLevelItem = class;
T3rdLevelOwner = class;
T3rdLevelOwner = class( TRealOwner< T3rdLevelOwner > )
end;
T3rdLevelItem = class( TRealItem< T3rdLevelOwner > )
end;
TInheritable3rdLevelItem< TOwner : class> = class;
TInheritable3rdLevelOwner< TOwner : class> = class;
TInheritable3rdLevelOwner< TOwner : class> = class( TInheritable2ndLevelOwner< TOwner > )
end;
TInheritable3rdLevelItem< TOwner : class> = class( TInheritable2ndLevelItem< TOwner > )
end;
implementation
{ TGItem<TOwner> }
constructor TGItem<TOwner>.Create(const pOwner: TOwner);
begin
inherited Create;
fOwner := pOwner;
end;
end.
UPD1
I updated your example using my principles. In the process I realised that your main problem was dealing with the fact that the top level item is, in fact, a list. You are trying to explain this to the compiler with your convoluted constructs, but that is not the way to do it.
interface
uses
System.Generics.Collections;
type
TGenericCollectionItem< TOwnerCollection : class > = class
private
FOwnerCollection: TList<TOwnerCollection>;
function GetIndex: Integer;
procedure SetIndex(const Value: Integer);
public
constructor Create(pOwnerCollection: TList<TOwnerCollection>);
property Index: Integer read GetIndex write SetIndex;
property OwnerCollection: TList<TOwnerCollection> read FOwnerCollection;
end;
TNamedGenericCollectionItem<TOwnerCollection: class> = class(TGenericCollectionItem< TOwnerCollection>)
public
private
FName: string;
public
property Name: string read FName write FName;
end;
type
TFrames = class;
TProject = class( TList< TFrames > )
private
FFrames : TFrames;
public
constructor Create;
end;
TFrames = class(TNamedGenericCollectionItem< TFrames>)
end;
implementation
{ TGenericCollectionItem<ACollectionOwnerType> }
constructor TGenericCollectionItem<TOwnerCollection>.Create(
pOwnerCollection: TList<TOwnerCollection>);
begin
inherited Create;
pOwnerCollection := fOwnerCollection;
end;
function TGenericCollectionItem<TOwnerCollection>.GetIndex: Integer;
begin
Result := OwnerCollection.IndexOf(Self);
end;
procedure TGenericCollectionItem<TOwnerCollection>.SetIndex(
const Value: Integer);
var
CurIndex: Integer;
begin
CurIndex := GetIndex;
if (CurIndex >= 0) and (CurIndex <> Value) then
FOwnerCollection.Move(CurIndex, Value);
end;
{ TProject }
constructor TProject.Create;
begin
inherited Create;
FFrames:= TFrames.Create( self );
end;
I hope that this helps.
I have a base class test define below
type
Tinfo = procedure of object;
Test = class(TObject)
public
procedure Add ( const a : Tinfo ); reintroduce ;
end;
procedure Test.Add(const a: Tinfo);
begin
Writeln('base class add function');
// dosomething more
end;
and I have a derived generic class from this base class
TTesting<T> = class(Test)
public
procedure Add ( const a : T ); reintroduce ;
end;
and I am typecasting T to Tinfo but it gives me the error
procedure TTesting<T>.Add(const a : T );
begin
inherited Add(Tinfo(a) ); // gives me error here
end;
is there any way I can implement this?
First your cast is wrong, you obviously want to cast a and not T.
However if you want to type cast on a procedure of object which is a type that cannot be polymorphic in any way it makes no sense to put that into a generic type at all.
What should T be? It only can be a TInfo in your code.
If you however want T to be any event/method type you should store a TMethod in your base class and then work with that in your generic class. But remember that you cannot have a constraint that limits T to be an event type. So you might check that in your constructor.
type
PMethod = ^TMethod;
Test = class(TObject)
public
procedure Add(const a: TMethod ); reintroduce ;
end;
procedure Test.Add(const a: TMethod);
begin
Writeln('base class add function');
// dosomething more
end;
type
TTesting<T> = class(Test)
public
constructor Create;
procedure Add(const a: T); reintroduce ;
end;
constructor TTesting<T>.Create;
begin
Assert(PTypeInfo(TypeInfo(T)).Kind = tkMethod);
inherited Create;
end;
procedure TTesting<T>.Add(const a: T);
begin
inherited Add(PMethod(#a)^);
end;
So assume this code work.
{***Start declaration of TMakeProd ***}
TListMakeProd = class (TListNF)
procedure SortProcProdSeqNum;
procedure LoadFromRep(aFileRep, aNo : String);
function Find(aMakeProdID : Integer) : TMakeProd;
function FindObj(aMakeProd : TMakeProd) : TMakeProd;
end;
TMakeProd = class (TProduct)
private
FMakeProductID : Integer;
FProdLotSize : Longint;
public
LiProcProd : TListProcProd;
{Load from a database.}
{ procedure SortLiProcProdSeqNum; }
constructor Init(aMakeProductID: Integer; aProdLotSize: Longint);
destructor Done; override;
destructor Destroy; override;
property MakeProductID : Integer read FMakeProductID write FMakeProductID ;
property ProdLotSize : Longint read FProdLotSize write FProdLotSize ;
function findNextProcProd(aProcProd: TProcProd) : TProcProd;
{ create function with return if required. }
end;
What I don't understand is this declaration LiProcProd : TListProcProd;
I know that TListProcProd is a class, everything else I understand it but this part I don't also this is just a class declaration and assume all the class have been properly declared
type
TMakeProd = class(TProduct)
....
LiProcProd : TListProcProd;
....
end;
In this declaration, LiProcProd is a public field. This is described by the documentation.