Appropriate object creation - finding universal solution

Question

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...

Answer 1

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;

Answer 2

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.

Answer 3

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.

Answer 4

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.