Les références de classe ou métaclasses

29/07/2004

Par Laurent Dardenne (home page)
 

Cet article est issue d'une discussion sur les métaclasses sur le forum de la FAQ Delphi de Developpez.com.

Les méthode de classes appelée parfois métaclasse et les références de classe sont des éléments du langage important sous Delphi. L'aide en ligne n'étant pas trés prolixe sur le sujet ( bien que de nombreux extraits émaillent mes propos) et n'ayant trouvé sur le net que des bribes d'information, cet article vous propose d'approfondir le sujet, enfin je l'espére.

Merci à Ptitbob, Nono40, Pierre Castelain, Hachesse, Bloon et Delphiprog.

type NomDeClasse = class (ClasseAncêtre)
  ListeMembre
 end;

procedure FaireQuelquechose; virtual; abstract;

...
EAbstractError = class(Exception);
...

var Liste:TStrings;
    Chaine:String;
begin
  Try
   Liste:=TStrings.Create;
   Try
     // La méthode Add appelle la méthode abstraite GetCount
    Liste.Add('Une chaîne');
   Except
   On EAbstractError do
    MessageDlg('Vous devez implémenter la méthode GetCount', mtError, [mbOK], 0);
   End ;
  Finally
   Liste.Free;
  end;
end;

175. Construction d'instance de '<...>' contenant des méthodes abstraites.

…
{ Forward class declarations }

  TStream = class;
  TFiler = class;
  TReader = class;
  TWriter = class;
  TComponent = class;
…

TPersistent = class(TObject)
…
  protected
    procedure DefineProperties(Filer: TFiler); virtual;
…
 // Et plus loin dans le code de l'unité la déclaration compléte de la classe TFiler
{ TFiler }
…
TFiler = class(TObject)
  private
    FStream: TStream;
    FBuffer: Pointer;
…

...
 TComponent = class;
 TComponentClass = class of TComponent;

...
  // Prédéclaration erronée
TUneClasseDeBase = class(TObject);

type

  TMethode = procedure of object;

  TNotifyEvent = procedure(Sender: TObject) of object;

type

  TNotifyEvent = procedure(Sender: TObject) of object;
  TMainForm = class(TForm)
    procedure ButtonClick(Sender: TObject);
    ...
  end;
var
  MainForm: TMainForm;
  OnClick: TNotifyEvent

OnClick := MainForm.ButtonClick;

type

 Fabrique = Function ():Byte of Object;

 Fabrique = Function (Reference : TControlClass; MonParent : TWinControl): TControl of Object;

type
  methode = procedure of object;

procedure TForm1.Button1Click(Sender: TObject);
var
  m : TMethod;
begin
  m.Data := self;
  m.Code := self.MethodAddress('Fermeture');
  methode(m);
end;

Code:
type
  methode = procedure (s : string) of object;

procedure TForm1.Button1Click(Sender: TObject);
var
  m : TMethod;
begin
  m.Data := self;
  m.Code := self.MethodAddress('Fermeture');
  methode(m)('Enregistre');
end;

TMethod est un enregistrement utilisé pour stocker les champs Code et Data comme étant du type Pointer.

type
  TMethod = record
  Code, Data: Pointer;
  end;

class of type

type TClass = class of TObject;

var ToutObjet : TClass;

...
Type -> IdentType
     -> TypeSimple
     -> TypeStruc
     -> TypePointeur
     -> TypeChaîne
     -> TypeProcédure
     -> TypeVariant
     -> TypeRefClass

TypeRestreint -> TypeObjet   {* Borland recommande ne plus utiliser ce type pour la programmation objet}
              -> TypeClasse
              -> TypeInterface

TypeRefClass -> CLASS OF IdentType
...

• Avec un constructeur virtuel pour créer un objet dont le type réel est inconnu au moment de la compilation
• Avec une méthode de classe pour effectuer une opération sur une classe dont le type réel est inconnu au moment de la compilation
• Comme opérande droite d'un opérateur is en vue d'accomplir un transtypage controlé lorsque le type est indéterminée au moment de la compilation
• Comme opérande droite d'un opérateur as en vue d'accomplir un transtypage controlé vers un type indéterminée au moment de la compilation

// Déclaration impossible
Var TClass : class of TObject;

   // Déclaration impossible
Function GetSize(Classe : class of TObject ):Integer ;

type TMaClasse = class
 ...
end;

type TMaClasse = class(TObject)
 ...
end;

type
 nomTypeObjet = object(typeObjetAncêtre)
  listeMembre
 end;

…
{ TComponent class reference type }

  TComponentClass = class of TComponent;
…
  TComponent = class(TPersistent)
  Private
   // Déclaration compléte de la classe
…
  TControl = class(TComponent)
  Private
   // Déclaration compléte de la classe
…
  TControlClass = class of TControl;

Var
 ComponentClass : TComponentClass ;
 ControlClass   : TControlClass

Begin
 ComponentClass := TComponent ; // Valide
 ComponentClass := TControl; // Valide
...

Var
 ComponentClass : TComponentClass ;
 ControlClass   : TControlClass

Begin
 ControlClass := TComponent ; // Invalide
 ControlClass := TControl; // Valide

if Instance is TControl
 then …
 else
  if Instance is TComponent
   then …
   else
    if Instance is TPersistent
     then …
     else
      if Instance is TObject
       then …

ControlClass   := Nil;

if ControlClass = Nil
   then Exit;

TClasseDeBase = class( TObject )
    Numero: Byte;
    constructor Create; { Constructeur statique }
  end;

  TClasseDescendante = class( TClasseDeBase )
     constructor Create; { Constructeur statique }
  end;

  TExemple = class( TClasseDeBase )
    constructor Create; { Constructeur statique}
  end;

  TClassDeClasseDeBase = class of TClasseDeBase;  { Référence de classe }

var
  Form1: TForm1;

  Reference : TClassDeClasseDeBase;       { Variable référence de classe }
  Instance  : TClasseDeBase;              { Variable d'instance de classe }

Instance  := Reference.Create;
 Memo1.Lines.Add('Création d''une instance de la classe '+Instance.Classname);

TClasseDeBase = class( TObject )
    Numero: Byte;
    constructor Create; Virtual;   { Constructeur Virtuel }
  end;

  TClasseDescendante = class( TClasseDeBase )
     constructor Create; override; { Constructeur surchargé }
  end;

  TExemple = class( TClasseDeBase )
    constructor Create; override;  { Constructeur surchargé }
  end;

1 procedure TForm1.Creer;
2 Begin
3  FreeAndNil(Instance);
4  case rgClasseObjet.ItemIndex of
5    0 : ControlClass:=TEdit;
6    1 : ControlClass:=TButton;
7    2 : ControlClass:=TMemo;
8 end;
9                                                          // Appel la méthode de classe
10 MemoLog.Lines.Add('Création d''une instance de la classe '+ControlClass.ClassName);
11 // provoque une erreur lors de la compilation :
12 // MemoLog.Lines.Add('Création d''une instance de classe '+ControlClass.ClassType);
13
14  Instance :=ControlClass.Create(Self );
15  Instance.Parent:=Panel1;
16 end;

77. Forme d'appel de méthode autorisée seulement pour méthodes de classe

function TForm1.FabriqueUnControl(Reference : TControlClass; MonParent : TWinControl): TControl;
begin
 MemoLog.Lines.Add('Création d''une instance de la classe '+Reference.ClassName);

 Result:=Reference.Create(Self); // Propriétaire :  Il contrôle quand le composant est libéré
 Result.Parent:=MonParent;        // Parent : C'est le contrôle fenêtré contenant le contrôle créé
end;

type TCollectionItemClass = class of TCollectionItem;
  ...
constructor Create(ItemClass: TCollectionItemClass);

...
procedure TForm1.Creer;
Begin
 FreeAndNil(Instance);
 case rgClasseObjet.ItemIndex of
   0 : ControlClass:=TEdit;
   1 : ControlClass:=TButton;
   2 : ControlClass:=TMemo;
   3 : ControlClass:=TObject;
 end;
...
procedure TForm1.Fabriquer;
Begin
 FreeAndNil(Instance);
 case rgClasseObjet.ItemIndex of
   0 : Instance:=FabriqueUnControl(TEdit,Panel1);
   1 : Instance:=FabriqueUnControl(TButton,Panel1);
   2 : Instance:=FabriqueUnControl(TMemo,Panel1);
   3 : Instance:=FabriqueUnControl(TObject,Panel1);
 end;
end;
...

Types incompatibles : '<TControlClass>' et '<Class Reference>'

3 : ControlClass:=TControlClass(TObject);

3 : Instance:=FabriqueUnControl(TControlClass(TObject),Panel1);

procedure TForm1.Creer;
Begin
 FreeAndNil(Instance);
 case rgClasseObjet.ItemIndex of
   0 : ControlClass:=TEdit;
   1 : ControlClass:=TButton;
   2 : ControlClass:=TMemo;
   3 : ControlClass:=TControlClass(TObject);
 end;
                                                       // Appel la méthode de classe
 MemoLog.Lines.Add('Création d''une instance de la classe '+ControlClass.ClassName);
 Try
  Instance :=ControlClass.Create(Self );
  Instance.Parent:=Panel1;
 Except
  On E:EAccessViolation do
   MessageDlg('La méthode create n''est pas adaptée pour la classe '+ControlClass.ClassName, mtError, [mbOK], 0);
 end;
end;

Try
  Instance :=ControlClass.Create(Self );
  Instance.Parent:=Panel1;
 Except
  On E:EAccessViolation do
   Instance :=ControlClass.Create;
 end;

If ControlClass is TEdit
  then ...

If ControlClass=TObject
  then ...

var ControlClass : TControlClass;
    ObjetClass	 : TClass;

begin
 ControlClass:=TEdit;
 ObjetClass:= TPersistent;
 
 If ControlClass=ObjetClass
  then ...

If ControlClass=TClass
  then ...

TObject.InheritsFrom

Détermine la relation entre deux types d'objet.

class function InheritsFrom(AClass: TClass): Boolean;

Description
Utilisez la méthode InheritsFrom pour déterminer si un type de classe donné est l'ancêtre d'un objet.
InheritsFrom renvoie True si le type d'objet spécifié par le paramètre AClass est bien l'ancêtre du type de l'objet,
ou le type même de l'objet. Sinon, elle renvoie False.

Remarque :
Les opérateurs is et as utilisent dans leur implémentation la méthode InheritsFrom. Cependant, l'opérateur is ne peut
déterminer la relation d'héritage que pour une instance. Alors que InheritsFrom, comme méthode de classe, est capable
de déterminer la relation entre des références de classe.

procedure TForm1.Creer;
Begin
 FreeAndNil(Instance);
 case rgClasseObjet.ItemIndex of
   0 : ControlClass:=TEdit;
   1 : ControlClass:=TButton;
   2 : ControlClass:=TMemo;
   3 : ControlClass:=TControlClass(TObject);
 end;
                                                       // Appel la méthode de classe
 MemoLog.Lines.Add('Création d''une instance de la classe '+ControlClass.ClassName);

 If ControlClass.InheritsFrom(TControl)
  then
    begin
     Instance :=ControlClass.Create(Self );
     Instance.Parent:=Panel1;
    end
  else Instance :=ControlClass.Create;
end;

...
  else TObject(Instance) :=TObject(ControlClass).Create;
end;

...
  else TObject(Instance) :=TClass(ControlClass).Create;
end;

// Identificateur de type référence de classe
type TClass = class of TObject;

  // Identificateur de type classe
type TPersistent = class(TObject);

ControlClass:=TControlClass(Sender.ClassType);

procedure TForm1.Creer;
Begin
 FreeAndNil(Instance);
 case rgClasseObjet.ItemIndex of
   0 : ControlClass:=TEdit;
   1 : ControlClass:=TButton;
   2 : ControlClass:=TMemo;
   3 : ControlClass:=TControlClass(TObject);
   4 : ControlClass:=TControlClass(TComponent);
 end;
                                                       // Appel la méthode de classe
 MemoLog.Lines.Add('Création d''une instance de la classe '+ControlClass.ClassName);

      // Vérification d'appartenance à une Hiérarchie de classe
 If ControlClass.InheritsFrom(TControl)
  then
    begin
     Instance:=ControlClass.Create(Self );
       // Vérification d'appartenance à une classse
     If ControlClass=TComponent
          // TComponent ne posséde pas de propriétés Parent
      then Exit;
     Instance.Parent:=Panel1;
    end
  else TObject(Instance):=TClass(ControlClass).Create;
end;

ResItem := GetResourceClass(FResType).CreateItem(Self, DirEntry);

class function ClassName: ShortString;

class function TObject.ClassName: ShortString;

Self : Class of ClassType

Var UnComposant:TButton;
    UneReference: TControlClass;
begin
   // Bien que UnComposant ne soit pas initialisé, on peut utiliser ces méthodes de classe
  ShowMessage('Référence d''objet '+UnComposant.ClassName);
  UneReference:=TControlClass(UnComposant.ClassType);

  ShowMessage('Référence de classe '+UneReference.ClassName);
  UnComposant:=TButton.Create(Self);
end;

TControlClass=TEdit.Text; // Invalide

TControlClass=GetClass(TEdit.Text);

UneClasse(GetClass(TEdit.Text)).Traitement(params)

• Traitement soit une méthode de classe. Sinon il n'est pas possible d'effectuer l'appel de méthode de cet exemple.
• Traitement soit une méthode virtuelle ou dynamique. Sinon on risque de perdre l'héritage et donc de ne pas appeler la bonne méthode en fonction de la classe réelle.

• si vous utilisez un nombre important de classes la propriété Sorted permet d'accélérer la recherche
• la persistence, c'est à dire la possibilité d'enregistrer cette liste sur disque.

Var mesClasses :TStringList;
begin
 ...
  // Enregistre le nom de la classe et le type de la classe mais pas l'objet
 mesClasses.AddObject('TMaClasse',TObject(TMaClasse));
 ...

Var mesClasses : TStringList;
    MaClasse   : TControlClass;
    i 	       : Integer;

begin
  ...
         // Recherche dans la liste d'association
  i := mesClasses.IndexOf('TEdit');

  if (i = -1)
      	// si pas trouvé, on renvoie nil
   then MaClasse := nil;
     	// si trouvé, on renvoie la classe associée
   else MaClasse:= TClass(mesClasses.objects[i]);
  ...

procedure addClass(UneClasse : TClass);
begin
  mesClasses.AddObject(UneClasse.ClassName,TObject(UneClasse));
end;

type
 TRefMesClasses = class of TMesClasses;
var
  classByName : TStringList;

// Enregistrer une classe
procedure registerClassByName(classe: TRefMesClasses);
begin
  // Ajout de la classe si elle n'est pas déjà référencée
  if (classByName.IndexOf(classe.ClassName) = -1) then
  begin
    classByName.AddObject(classe.ClassName,TObject(classe));
  end;
end;

// Obtenir une classe par son nom
function getClassByName(nom: string): TRefMesClasses;
var
  i : integer;
begin
  // Recherche dans la liste des classByName
  i := classByName.IndexOf(nom);
  // si pas trouvé, on renvoie nil
  if (i = -1) then
  begin
    result := nil;
  end
  // si trouvé, on renvoie la classe associée
  else
  begin
    result := TRefMesClasses(classByName.objects[i]);
  end
end;

// Au début de l'application, enregistrer les classes  :
classByName := TStringList.Create;
registerClassByName(MaClasse1);
...
// Fin d'application, libérer classByName
classByName.Free;
// Utilisation :
getClassByName(Edit1.Text).Traitement...

...
 case rgClasseObjet.ItemIndex of
   0 : ControlClass:=TEdit;
   1 : ControlClass:=TButton;
   2 : ControlClass:=TMemo;
   3 : ControlClass:=TControlClass(TObject);
 end;
 MemoLog.Lines.Add('Création d''une instance de la classe '+ControlClass.ClassName);

 Instance :=ControlClass.Create(Self );
 Instance.Parent:=Panel1;

procedure TForm1.Creer;
Begin
 if (rgClasseObjet.ItemIndex <= -1)
  then Exit;

 FreeAndNil(Instance);

 with rgClasseObjet do
   // Appel la méthode de classe
  Instance := TControlClass(Items.Objects[ItemIndex]).Create(Self);
 Instance.Parent:=Panel1;

 MemoLog.Lines.Add('Création d''une instance de la classe '+Instance.ClassName);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 ControlClass :=Nil;
 Instance :=Nil;
 rgClasseObjet.Items.AddObject('TEdit',TObject(TEdit));
 rgClasseObjet.Items.AddObject('TButton',TObject(TButton));
 rgClasseObjet.Items.AddObject('TMemo',TObject(TMemo));
end;