Why in the code below, do I get the "Failed" message rather than "Succeeded"
Background: I like to have class procedures that instantiate their owner object, do something, and then free it.
However, this approach doesn't work if I have a descendant object:
Any suggestions on how to provide class procedures in a base class that can be called as a child? Am I thinking about this wrongly?
Type
TBase = class(TObject)
Protected
Procedure Proc1; Virtual;
Public
Class Procedure MyClassProc;
end;
Class Procedure TBase.MyClassProc;
Var
Base: TBase;
begin
Base := TBase.Create;
Base.Proc1;
Base.Free;
end;
Procedure TBase.Proc1;
begin
Assert(FALSE, 'Failed');
end;
type
TChild = class(TBase)
protected
Procedure Proc1; Override;
end;
Procedure TChild.Proc1;
begin
ShowMessage('Succeeded');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TChild.MyClassProc;
end;
You can do it easily with meta-programmation! Just change "TBase.Create" to "Self.Create" "self" represents the current class, it doesn't metter if is a base o a child class.
Type
TBase = class(TObject)
Protected
Procedure Proc1; Virtual;
Public
Class Procedure MyClassProc;
end;
Class Procedure TBase.MyClassProc;
Var
MyObject: TBase;
begin
// MyObject := TBase.Create;
MyObject := Self.Create; // The Magic goes here, self is the class that's calling this method, in this case, TChild }
MyObject.Proc1;
MyObject.Free;
end;
Procedure TBase.Proc1;
begin
Assert(FALSE, 'Failed');
end;
type
TChild = class(TBase)
protected
Procedure Proc1; Override;
end;
Procedure TChild.Proc1;
begin
ShowMessage('Succeeded');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TChild.MyClassProc;
end;
Strip everything down to the bare minimum, and you will see that you only ever create a TBase instance, so consequently only TBase.Proc1() will ever be called. If you want to have TChild.Proc1() be called you need to create a TChild instance and let polymorphism work its magic.
There could however be better ways to achieve your goal (whatever it is) than to have a class method create an object instance to do something. Maybe you should clarify your question.
Here it is
Add
TBase = class;
TBaseClass = class of TBase;
TBase = class(TObject)
protected
class function GetBaseClass: TBaseClass; virtual;
function TBase.GetBaseClass: TBaseClass;
begin
Result := TBase;
end;
TChild = class(TBase)
protected
class function GetBaseClass: TBaseClass; override;
function TChild.GetBaseClass: TBaseClass;
begin
Result := TChild;
end;
Change
from
Base := TBase.Create;
to
Base := GetBaseClass.Create;
Enjoy your work
Cheer
A Pham
Related
There are 3 classes (there may be much more), which have the same procedure (procedure Populate). They are nearly identical and differs only by object creation. All I want is to write a universal procedure in the base class, which will replace this notorious repeating of code forever. I am not really sure, if I can express exactly what I am up to, but look at the code below and see.
TGrandFather = class(TObject)
end;
TFather = class(TGrandFather)
end;
TSon = class(TFather)
end;
TGrandson.... and so on...
TGrandFathers = class (TList)
public
procedure Populate(Amount:Integer);
end;
TFathers = class (TGrandFathers)
public
procedure Populate(Amount:Integer);
end;
TSons = class (TFathers)
public
procedure Populate(Amount:Integer);
end;
TGrandsons....
...
procedure TGrandFathers.Populate(Amount:Integer);
var i:integer;
xGrandFather:TGrandFather;
begin
for i := 0 to Amount do
begin
xGrandFather:=TGrandFather.Create;
Add(xGrandFather);
end;
end;
procedure TFathers.Populate(Amount:Integer);
var i:integer;
xFather:TFather;
begin
for i := 0 to Amount do
begin
xFather:=TFather.Create; //this is the point, which makes trouble
Add(xFather);
end;
end;
procedure TSons.Populate(Amount:Integer);
var i:integer;
xSon:TSon;
begin
for i := 0 to Amount do
begin
xSon:=TSon.Create; //this is the point, which makes trouble
Add(xSon);
end;
end;
procedure Grandsons...
Thanx...
To answer your question, you could use a metaclass through "class of" if you want to go the route you are going. This block of code demonstrates how you would accomplish that. The hierarchy needs to be cleaned up but you should get the gist of what is going on through this code.
A metaclass is a class whose instances are classes. This allows you to build a more generic framework because you can then use your metaclass to create the classes that you need.
type
TGrandFather = class(TObject)
end;
TStrangeHeirarchyClass = class of TGrandFather;
TFather = class(TGrandFather)
end;
TSon = class(TFather)
end;
TGrandFathers = class(TList)
protected
procedure PopulateInternal(aAmount:Integer; aContainedClass:
TStrangeHeirarchyClass);
public
procedure Populate(Amount:Integer);
end;
TFathers = class (TGrandFathers)
public
procedure Populate(Amount:Integer);
end;
TSons = class (TFathers)
public
procedure Populate(Amount:Integer);
end;
implementation
procedure TGrandFathers.Populate(Amount:Integer);
begin
PopulateInternal(Amount, TGrandFather);
end;
procedure TGrandFathers.PopulateInternal(aAmount:Integer; aContainedClass:
TStrangeHeirarchyClass);
var
i:integer;
xFamilyMember:TGrandFather;
begin
for i := 0 to aAmount do
begin
xFamilyMember := aContainedClass.Create;
Add(xFamilyMember);
end;
end;
procedure TFathers.Populate(Amount:Integer);
begin
PopulateInternal(Amount, TFather);
end;
procedure TSons.Populate(Amount:Integer);
begin
PopulateInternal(Amount, TSon);
end;
The way it works is that the metaclass TStrangeHeirarchyClass, which you can use just like a regular data type, stores the underlying class that you would like to work with. You can pass the type in as a parameter (like I did in the code example above) or store it in the class as a property or field like this:
TGrandFathers = class(TList)
private
FContainedClass: TStrangeHeirarchyClass;
public
procedure Populate(Amount:Integer);
property ContainedClass: TStrangeHeirarchyClass read
FContainedClass write FContainedClass;
end;
Once you have set this property you would then be able to use it to create instances of the class type that it was set to. So, setting the ContainedClass as a TFather would result in calls to ContainedClass.Create creating instances of TFather.
As David indicated in the comments, you will run into problems if you use a metaclass and override the default constructor. Your code in the constructor will never run. You either need to wither use virtual constructors or override the existing AfterConstruction method which is a virtual method that is called by the constructor. Something like this would be an example if you were using AfterConstruction:
TGrandFathers = class(TList)
protected
FContainedClass: TStrangeHeirarchyClass;
public
procedure AfterConstruction; override;
procedure Populate(Amount:Integer);
end;
TFathers = class (TGrandFathers)
public
procedure AfterConstruction; override;
end;
TSons = class (TFathers)
public
procedure AfterConstruction; override;
end;
implementation
procedure TGrandFathers.AfterConstruction;
begin
inherited;
FContainedClass := TGrandFather;
// Other construction code
end;
procedure TGrandFathers.Populate(aAmount:Integer);
var
i:integer;
xFamilyMember:TGrandFather;
begin
for i := 0 to aAmount do
begin
xFamilyMember := FContainedClass.Create;
Add(xFamilyMember);
end;
end;
procedure TFathers.AfterConstruction;
begin
inherited;
FContainedClass := TFather;
// Other construction code
end;
procedure TSons.AfterConstruction;
begin
inherited;
FContainedClass := TSon;
// Other construction code
end;
Your hierarchy looks very strange though. I think something like this would be more appropriate:
type
TRelationType = (ptSon, ptFather, ptGrandfather);
TPerson = class;
TRelation = class(TObject)
strict private
FRelationship: TRelationType;
FRelation: TPerson;
public
property Relation: TPerson read FRelation write FRelation;
property Relationship: TRelationType read FRelationship write FRelationship;
end;
TRelationList = class(TList)
//...
end;
TPerson = class(TObject)
strict private
FPersonName: string;
FRelations: TRelationList;
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
property PersonName: string read FPersonName write FPersonName;
property Relations: TRelationList read FRelations;
end;
implementation
procedure TPerson.AfterConstruction;
begin
inherited;
FRelations := TRelationList.Create;
end;
procedure TPerson.BeforeDestruction;
begin
FRelations.Free;
inherited;
end;
This seems to work:
//MMWIN:CLASSCOPY
unit _MM_Copy_Buffer_;
interface
implementation
type
TBaseSelfCreating = class(TObject)
procedure Populate(Amount: Integer);
procedure Add(Obj: TObject);
end;
{TBaseSelfCreating}
procedure TBaseSelfCreating.Add(Obj: TObject);
begin
Assert(Obj is TBaseSelfCreating);
Assert(Obj <> Self);
Obj.Free;
end;
procedure TBaseSelfCreating.Populate(Amount: Integer);
var
i: Integer;
begin
for i := 1 to Amount do Add(Self.ClassType.Create);
end;
end.
Simply use Self.ClassType.Create:
program Project13;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TFoo1 = class
procedure Boo;
end;
TFoo2 = class(TFoo1)
end;
{ TFoo1 }
procedure TFoo1.Boo;
var
x: TFoo1;
begin
x := Self.ClassType.Create as TFoo1;
write(Cardinal(Self):16, Cardinal(x):16);
Writeln(x.ClassName:16);
end;
begin
try
TFoo1.Create.Boo;
TFoo2.Create.Boo;
Readln;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
If you do not want to use Generics or you are using a version of Delphi without Generics, then this is a way. Yes, I know I can use forward declaration to remove one class, but this is clearer to follow.
Interface
type
TBaseAncestor = class
end;
TBaseClass = class of TBaseAncestor;
TGrandFathers = class (TBaseAncestor)
FClassType : TBaseClass;
constructor Create (AOwner : TControl); reintroduce; virtual;
procedure Populate;
procedure Add (X : TBaseAncestor);
end;
TFathers = class (TGrandFathers)
constructor Create (AOwner : TControl); override;
end;
Implementation
{ TGrandFathers }
constructor TGrandFathers.Create(AOwner: TControl);
begin
inherited Create;
FClassType := TGrandFathers;
end;
procedure TGrandFathers.Add (X : TBaseAncestor);
begin
end;
procedure TGrandFathers.Populate;
const
Amount = 5;
var
I : integer;
x : TBaseAncestor;
begin
for I := 0 to Amount do
begin
x := FClassType.Create;
Add (x);
end;
end;
{ TFathers }
constructor TFathers.Create(AOwner: TControl);
begin
inherited;
FClassType := TFathers;
end;
Each descendant stores its class into the class variable. And Populate uses this for Creation. I have been using this before Generics came along.
I am working on a component that is derived from a commercial component suite, and have run into a challenge, which I've never considered before. Consider the following code snippet:
TMyClass = class
protected
procedure SomeMethod; virtual;
end;
TMyClass1 = class(TMyClass)
protected
procedure SomeMethod; override;
end;
TMyMode = (mmOne, mmTwo);
TMyClass2 = class(TMyClass1)
private
FMode: TMyMode;
protected
procedure SomeMethod; override;
public
property Mode: TMyMode read FMode write FMode;
end;
...
procedure TMyClass2.SomeMethod;
begin
if FMode = mmOne then inherited SomeMethod
else inherited TMyClass.SomeMethod;
end;
So if Mode = mmOne then I inherit as normal, but if it is mmTwo, I still want to inherit the code from my ancestor's ancestor, but not what was introduced in the ancestor. I've tried the above, with no success, and since I've never encountered this before, I gather it's not possible. Any takers?
You can do this with class helpers:
type
TA = class
public
procedure X; virtual;
end;
TB = class(TA)
public
procedure X; override;
end;
TA_Helper = class helper for TA
procedure A_X;
end;
TC = class(TB)
public
procedure X; override;
end;
procedure TA.X;
begin
// ...
end;
procedure TB.X;
begin
// ...
end;
procedure TA_Helper.A_X;
begin
inherited X; // TA.X
end;
procedure TC.X;
begin
A_X;
inherited X; // TB.X
end;
I think class helpers exist in D2006, but if they don't, you can also use a hack to the same effect:
// ...
TA_Helper = class(TA)
procedure A_X;
end;
// ...
procedure TC.X;
begin
TA_Helper(Self).A_X;
inherited X; // TB.X
end;
there is another solution of this task without class-helpers or additional methods (as in #hvd answer). you can get base class methods code address and invoke it with self Data-pointer:
updated code, without rtti
unit Unit4;
interface
type
TA = class(TObject)
protected
procedure Test(); virtual;
end;
TB = class(TA)
protected
procedure Test(); override;
end;
TC = class(TB)
public
procedure Test(); override;
end;
implementation
procedure TA.Test;
begin
writeln('TA.Test()');
end;
procedure TB.Test;
begin
writeln('TB.Test');
end;
procedure TC.Test;
var TATest : procedure of object;
begin
writeln('TC.Test();');
writeln('call inherited TB: ');
inherited Test();
writeln('call inherited TA:');
TMethod(TATest).Data := self;
TMethod(TATest).Code := #TA.Test;
TATest();
end;
end.
I have a main class and several inherited classes that implement a method with the same name, like this:
MainClass = class(TImage)
//main class methods...
end;
MyClass1 = class(MainClass)
procedure DoSomething;
end;
MyClass2 = class(MainClass)
procedure DoSomething;
end;
MyClass3 = class(MainClass)
procedure DoSomething;
end;
I also have a TList containing pointers to object instances (of several classes).
If I want to call the right DoSomething procedure for each class, do I use the following?
if TList[i] is MyClass1 then
MyClass1(TList[i]).DoSomething
else if TList[i] is MyClass2 then
MyClass2(TList[i]).DoSomething
else if TList[i] is MyClass3 then
MyClass3(TList[i]).DoSomething
Is there some casting method that allows me to do this in a few lines of code?
Yes, virtual polymorphism :)
MainClass = class(TImage)
procedure DoSomething; virtual;
end;
MyClass1 = class(MainClass)
procedure DoSomething; override;
end;
MyClass2 = class(MainClass)
procedure DoSomething; override;
end;
MyClass3 = class(MainClass)
procedure DoSomething; override;
end;
And then just:
if TList[i] is MainClass then
MainClass(TList[i]).DoSomething
If you don't want to do an empty MainClass.DoSomething procedure, you can also mark it virtual; abstract;.
The virtual inheritance answer is the best for the situation you described where the classes descend from a common base class, but if you have a situation where there is not a common base class between your classes and you need this behavior, you can use interfaces instead to achieve the same result:
IMainInterface = interface
['{0E0624C7-85F5-40AF-ADAC-73B7D79C264E}']
procedure DoSomething;
end;
MyClass = class(TInterfacedObject, IMainInterface)
procedure DoSomething;
destructor Destroy; override;
end;
MyClass2 = class(TInterfacedObject, IMainInterface)
procedure DoSomething;
end;
MyClass3 = class(TInterfacedObject, IMainInterface)
procedure DoSomething;
end;
and then using it would look something like this:
var
i: integer;
list: TInterfaceList;
main: IMainInterface;
begin
list := TInterfaceList.Create;
list.Add(MyClass.create);
list.Add(MyClass2.Create);
list.Add(MyClass3.Create);
for i := 0 to 2 do
if Supports(list[i], IMainInterface, main) then
main.DoSomething;
list.Free;
TMyBaseClass=class
constructor(test:integer);
end;
TMyClass=class(TMyBaseClass);
TClass1<T: TMyBaseClass,constructor>=class()
public
FItem: T;
procedure Test;
end;
procedure TClass1<T>.Test;
begin
FItem:= T.Create;
end;
var u: TClass1<TMyClass>;
begin
u:=TClass1<TMyClass>.Create();
u.Test;
end;
How do I make it to create the class with the integer param. What is the workaround?
Just typecast to the correct class:
type
TMyBaseClassClass = class of TMyBaseClass;
procedure TClass1<T>.Test;
begin
FItem:= T(TMyBaseClassClass(T).Create(42));
end;
Also it's probably a good idea to make the constructor virtual.
You might consider giving the base class an explicit method for initialization instead of using the constructor:
TMyBaseClass = class
public
procedure Initialize(test : Integer); virtual;
end;
TMyClass = class(TMyBaseClass)
public
procedure Initialize(test : Integer); override;
end;
procedure TClass1<T>.Test;
begin
FItem:= T.Create;
T.Initialize(42);
end;
Of course this only works, if the base class and all subclasses are under your control.
Update
The solution offered by #TOndrej is far superior to what I wrote below, apart from one situation. If you need to take runtime decisions as to what class to create, then the approach below appears to be the optimal solution.
I've refreshed my memory of my own code base which also deals with this exact problem. My conclusion is that what you are attempting to achieve is impossible. I'd be delighted to be proved wrong if anyone wants to rise to the challenge.
My workaround is for the generic class to contain a field FClass which is of type class of TMyBaseClass. Then I can call my virtual constructor with FClass.Create(...). I test that FClass.InheritsFrom(T) in an assertion. It's all depressingly non-generic. As I said, if anyone can prove my belief wrong I will upvote, delete, and rejoice!
In your setting the workaround might look like this:
TMyBaseClass = class
public
constructor Create(test:integer); virtual;
end;
TMyBaseClassClass = class of TMyBaseClass;
TMyClass = class(TMyBaseClass)
public
constructor Create(test:integer); override;
end;
TClass1<T: TMyBaseClass> = class
private
FMemberClass: TMyBaseClassClass;
FItem: T;
public
constructor Create(MemberClass: TMyBaseClassClass); overload;
constructor Create; overload;
procedure Test;
end;
constructor TClass1<T>.Create(MemberClass: TMyBaseClassClass);
begin
inherited Create;
FMemberClass := MemberClass;
Assert(FMemberClass.InheritsFrom(T));
end;
constructor TClass1<T>.Create;
begin
Create(TMyBaseClassClass(T));
end;
procedure TClass1<T>.Test;
begin
FItem:= T(FMemberClass.Create(666));
end;
var
u: TClass1<TMyClass>;
begin
u:=TClass1<TMyClass>.Create(TMyClass);
u.Test;
end;
Another more elegant solution, if it is possible, is to use a parameterless constructor and pass in the extra information in a virtual method of T, perhaps called Initialize.
What seems to work in Delphi XE, is to call T.Create first, and then call the class-specific Create as a method afterwards. This is similar to Rudy Velthuis' (deleted) answer, although I don't introduce an overloaded constructor. This method also seems to work correctly if T is of TControl or classes like that, so you could construct visual controls in this fashion.
I can't test on Delphi 2010.
type
TMyBaseClass = class
FTest: Integer;
constructor Create(test: integer);
end;
TMyClass = class(TMyBaseClass);
TClass1<T: TMyBaseClass, constructor> = class
public
FItem: T;
procedure Test;
end;
constructor TMyBaseClass.Create(test: integer);
begin
FTest := Test;
end;
procedure TClass1<T>.Test;
begin
FItem := T.Create; // Allocation + 'dummy' constructor in TObject
try
TMyBaseClass(FItem).Create(42); // Call actual constructor as a method
except
// Normally this is done automatically when constructor fails
FItem.Free;
raise;
end;
end;
// Calling:
var
o: TClass1<TMyClass>;
begin
o := TClass1<TMyClass>.Create();
o.Test;
ShowMessageFmt('%d', [o.FItem.FTest]);
end;
type
TBase = class
constructor Create (aParam: Integer); virtual;
end;
TBaseClass = class of TBase;
TFabric = class
class function CreateAsBase (ConcreteClass: TBaseClass; aParam: Integer): TBase;
class function CreateMyClass<T: TBase>(aParam: Integer): T;
end;
TSpecial = class(TBase)
end;
TSuperSpecial = class(TSpecial)
constructor Create(aParam: Integer); override;
end;
class function TFabric.CreateAsBase(ConcreteClass: TBaseClass; aParam: Integer): TBase;
begin
Result := ConcreteClass.Create (aParam);
end;
class function TFabric.CreateMyClass<T>(aParam: Integer): T;
begin
Result := CreateAsBase (T, aParam) as T;
end;
// using
var
B: TBase;
S: TSpecial;
SS: TSuperSpecial;
begin
B := TFabric.CreateMyClass <TBase> (1);
S := TFabric.CreateMyClass <TSpecial> (1);
SS := TFabric.CreateMyClass <TSuperSpecial> (1);
I want to limit the access of protected methods to certain inherited classes only.
For example there is a base class like
TBase = Class
Protected
Method1;
Method2;
Method3;
Method4;
End;
I have two classes derived from TBase
TDerived1 = Class(TBase)
//Here i must access only Method1,Method2 and Method3
End;
TDerived2 = Class(TBase)
//Here i must access only Method3 and Method4
End;
Then is it possible to
access only Method1, Method2 and Method3 when i use objects of TDerived1 and
Method3 and Method4 when i use objects of TDerived2
There's no way to do that. If a method is protected, then all descendant classes have access to it. You might want to rethink your class design if you have two separate sets of functionality that can be divided that easily.
I'd split them, similar to Jeroen's answer:
TBase = class
end;
TBase12 = class(TBase)
protected
procedure Method1;
procedure Method2;
end;
TBase34 = class(TBase)
protected
procedure Method3;
procedure Method4;
end;
TDerived1 = class(TBase12)
end;
TDerived2 = class(TBase34)
end;
From what you describe, this seems to better model your requirements than a "monolithic" base class (like Mason already wrote).
One more way - you can do this using Interfaces...
IBase1 = interface
// press Ctrl+Shift+G here to generate your own sexy GUID
procedure Method1;
procedure Method2;
end;
IBase2 = interface
// press Ctrl+Shift+G here again
procedure Method3;
procedure Method4;
end;
TBase = class(TInterfacedObject, IBase1, IBase2)
public
{ IBase1 }
procedure Method1;
procedure Method2;
{ IBase2 }
procedure Method3;
procedure Method4;
end;
var
B1: IBase1;
B2: IBase2;
begin
B1 := TBase.Create as IBase1;
B2 := TBase.Create as IBase2;
B1.Method1; // works
B1.Method3; // Can't compile
B2.Method3; // works
end;
Seems to me your methods aren't declared in the right place.
If Method1 and Method2 are not called in TBase, and should only be called from TDerived1 and descendents... then those methods should be declared in TDerived1.
If Method1/2 access private fields of TBase, then you should have properties or Getter/setter to those field in TBase.
But unless you give more specific reasons as to why those methods need to be in declared in TBase, I'd say it's just bad design to declare them there.
A solution that works in a similar way to publish private/protected/public properties that works for methods.
So you could do it like this:
unit PropertyAndMethodVisibilityPromotionUnit;
interface
type
TBase = class
private
procedure Method1;
procedure Method2;
procedure Method3;
procedure Method4;
end;
TBase1 = class(TBase)
protected
procedure Method1;
procedure Method2;
end;
TBase2 = class(TBase)
protected
procedure Method3;
procedure Method4;
end;
TDerived1 = class(TBase1)
//Here i must access only Method1 and Method2
end;
TDerived2 = class(TBase2)
//Here i must access only Method3 and Method4
end;
implementation
procedure TBase.Method1;
begin
end;
procedure TBase.Method2;
begin
end;
procedure TBase.Method3;
begin
end;
procedure TBase.Method4;
begin
end;
procedure TBase1.Method1;
begin
inherited;
end;
procedure TBase1.Method2;
begin
inherited;
end;
procedure TBase2.Method3;
begin
inherited;
end;
procedure TBase2.Method4;
begin
inherited;
end;
end.
Notes:
This only works if TBase, TBase1 and TBase2 are in the same unit.
It is a hack working around a potentially weak class design, so be sure you review your class design
--jeroen
ok... Here's a possible way to achieve what you are looking for. I think it requires Delphi 2005 or later though. (Or whatever version that introduced the "Strict Protected|private" visibility)
TBase = Class
Strict Protected
procedure Method1;
procedure Method2;
procedure Method3;
procedure Method4;
End;
TDerived1 = Class(TBase)
Protected
procedure Method1;
procedure Method2;
procedure Method3;
End;
TDerived2 = Class(TBase)
Protected
procedure Method3;
procedure Method4;
End;
TUserClass = class
FImplementer : TDerived1;
end;
And the methods look like this
procedure TDerived2.Method3;
begin
inherited Method3;
end;
But your requirements make me wonder if your method really belongs to your TBase class. Seems they should be static procedure, or maybe class procedure of another class. I don't think they really belong to TBase.