Discussion :

[Andnotor]

Salut à tous !

Qui ne s'est jamais dit qu'il serait pratique de pouvoir ajouter de nouveaux champs à un assistant de classe ? Je vous propose aujourd’hui une petite unité permettant de faire cela de façon totalement transparente.

Sur le principe il ne s'agit que de lier une allocation avec notre objet. Cette liaison est faite à l'aide d'un TDictionary<TObject, pointer> où la clé est l'instance de notre objet et la valeur une instance d'une classe contenant nos champs. La valeur est définie en pointeur non typé puisque ce type est compatible avec tout type de pointeur, ce qui nous évite des transtypages par la suite.

L'assistant de classe doit obligatoirement contenir une méthode permettant de récupérer cette liaison. C'est la seule prérogative, à part la déclaration des champs bien sûr.

Voici la structure et l'implémentation de base d'un assistant "étendu" :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
type
  TObjectHelper = class helper for TObject
  private type
    TFields = class(THelperFields)
      // Les nouveaux champs
    end;
 
  private
    function Fields :TFields;
  end;
 
implementation
 
function TObjectHelper.Fields: TFields;
begin
  Result := THelperFieldsObject.Get(Self, TFields);
end;

Certains se demanderont peut-être pourquoi passer par une classe TFields et non un simple enregistrement. Les raisons sont multiples :

• avoir un constructeur (voire un destructeur) pour l'initialisation des champs peut être pratique. Accessoirement c'est pour cela que TFields dérive de THelperFields et non de TObject : avoir un constructeur surchargeable ;
• le polymorphisme fait que le type réel n'a pas besoin d'être connu. Avec un enregistrement nous ne pourrions que passer sa taille et récupérer un pointeur après GetMem ;
• mais la principale est la gestion des types managés. Sur un enregistrement et après FreeMem, nous nous retrouverions avec des fuites mémoires.

Voici un exemple plus complet après l'ajout d'une propriété Champ1 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
type
  TObjectHelper = class helper for TObject
  private type
    TFields = class(THelperFields)
      Champ1 :integer;
    end;
 
  private
    function  Fields :TFields;
    function  GetChamp1: integer;
    procedure SetChamp1(const Value: integer);
  public
    property  Champ1 :integer read GetChamp1 write SetChamp1;
  end;
 
implementation
 
function TObjectHelper.Fields: TFields;
begin
  Result := THelperFieldsObject.Get(Self, TFields);
end;
 
function TObjectHelper.GetChamp1: integer;
begin
  Result := Fields.Champ1;
end;
 
procedure TObjectHelper.SetChamp1(const Value: integer);
begin
  Fields.Champ1 := Value;
end;

Comme vous le voyez, rien de compliqué


Qu'est-ce que tout cela implique dans notre code ? La réponse est simple : rien ! l'unité proposée se chargeant de tout vous n'aurez toujours qu'un TObject.Create/Object.Free.

La fonction THelperFieldsObject.Get se charge de créer le manager ainsi que notre objet "Champs" et maintenir la liaison dans un TDictionary.

Mais comment sont libérés ses champs sur Free ? me direz-vous. Et bien certains d'entre-vous le savent peut-être ; il est possible depuis XE de surcharger une méthode virtuelle... en runtime, une forme d'héritage dynamique. Cette mise en route se fait à l'aide d'un TVirtualMethodInterceptor. Dès lors nous n'avons plus qu'à insérer une méthode de libération dans cette chaîne polymorphe et le tour est joué ! La méthode qui nous intéresse à surcharger est évidemment FreeInstance.

Voici la fonction Get :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
class function THelperFieldsObject.Get(aInstance: TObject; aFieldsClass: THelperFieldsClass): pointer;
var
  VMI :TVMI;
begin
  TMonitor.Enter(FLock);
  try
    // Création du manager ou récupération des champs s'ils existent
    if not Assigned(FHelperFields)
    then FHelperFields := THelperFieldsObject.Create
    else if FHelperFields.ObjectList.TryGetValue(aInstance, Result) then Exit;
 
    // Création des champs et ajout au dictionnaire
    Result := aFieldsClass.Create;
    FHelperFields.ObjectList.Add(aInstance, Result);
 
    // Création de l'intercepteur s'il n'existe pas encore pour ce type
    if not FHelperFields.VMIList.TryGetValue(aInstance.ClassType, VMI) then
    begin
      VMI.RefCount    := 1;
      VMI.Interceptor := TVirtualMethodInterceptor.Create(aInstance.ClassType);
      VMI.Interceptor.OnBefore := VMIOnBefore;
    end
    else inc(VMI.RefCount);
 
    // Liaison entre l'objet et l'intercepteur
    VMI.Interceptor.Proxify(aInstance);
 
    // Ajout de l'intercepteur au dictionnaire ou mise à jour du RefCount
    FHelperFields.VMIList.AddOrSetValue(aInstance.ClassType, VMI);
 
  finally
    TMonitor.Exit(FLock);
  end;
end;

Et la fonction de libération VMIOnBefore :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
class procedure THelperFieldsObject.VMIOnBefore(aInstance: TObject; aMethod: TRttiMethod; const aArgs: TArray<TValue>; out aDoInvoke: Boolean; out aResult: TValue);
var
  VMI     :TVMI;
  PFields :pointer;
begin
  // Seule FreeInstance nous intéresse
  if not SameText(aMethod.Name, 'FreeInstance') then Exit;
 
  TMonitor.Enter(FLock);
  try
    if FHelperFields.VMIList.TryGetValue(aInstance.ClassType, VMI) then
    begin
      // Suppression de la liaison
      VMI.Interceptor.Unproxify(aInstance);
      dec(VMI.RefCount);
 
      // Libération de l'intercepteur si plus utilisé. Asynchrone puisque nous sommes dans une méthode de cet objet
      if VMI.RefCount = 0 then
      begin
        FHelperFields.VMIList.Remove(aInstance.ClassType);
        AsynFree(VMI.Interceptor);
      end
      else FHelperFields.VMIList.AddOrSetValue(aInstance.ClassType, VMI);
    end;
 
    // Libération des champs
    if FHelperFields.ObjectList.TryGetValue(aInstance, PFields) then
    begin
      FHelperFields.ObjectList.Remove(aInstance);
      TObject(PFields).Free;
    end;
 
    // Libération du manager si plus utilisé
    if FHelperFields.ObjectList.Count = 0 then
      FreeAndNil(FHelperFields);
 
  finally
    TMonitor.Exit(FLock);
  end;
end;

A noter encore qu'il n'y a aucun overhead systématique, notre objet "Champs" n'est créé que lors du premier accès à un champ et l'intercepteur n'est appliqué à cet objet qu'à ce moment-là.

Dernière remarque : le principe évoqué ici n'est applicable qu'aux assistants de classe, pas aux assistants d'enregistrement dépourvu de notion d'héritage, donc de méthode virtuelle.


Voilà ! et comme d'hab', amusez-vous bien

EDIT:

Version 2:
Correction sur la VMIList. Utilise le ClassName plutôt que le ClassType. Elle est également transformée en interface pour se passer de cette destruction asynchrone.
Gère maintenant les assistants multiples : le cas d'un assistant sur une classe ancêtre en plus de la classe courante.

EDIT:

Version finale:
Pas convaincu par l'interface, l'objet est de toute façon libéré trop tôt. Supprimé !
Simplification de l'accès aux champs par une méthode de classe de THelperFields, la méthode Fields devient Result := TFields.Get(Self).

Delphi Add field/property to class helpers

[Charly910]

Bonjour Andnotor,





A+
Charly

[Papy214]

C'est vrai que c'est quelque chose qui manquait.



Je viens de tester sous XE7 et j'ai 2 problèmes.

D'abord, Delphi ne donne pas la complétion de code mais ça ce n'est pas trop grave.

Par contre, le code suivant ne fonctionne pas. en fait, le programme se fige dans le FormCreate.
Si je commente la ligne d'initialisation du champ, ça fonctionne. Est-ce qu'il faut éviter de l'utiliser dans le create ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
 
unit Unit4;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, HelperFields;
 
type
  TForm4 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormClick(Sender: TObject);
  end;
 
  TFormHelper = class helper for TForm
  private type
    TFields = class(THelperFields)
      Champ1 :integer;
    end;
  private
    function Fields: TFields;
    function GetChamp1: integer;
    procedure SetChamp1(const Value: integer);
  public
    property  Champ1 :integer read GetChamp1 write SetChamp1;
  end;
 
var
  Form4: TForm4;
 
implementation
 
{$R *.dfm}
 
{ TFormHelper }
 
function TFormHelper.Fields: TFields;
begin
 Result := THelperFieldsObject.Get(Self, TFields);
end;
 
function TFormHelper.GetChamp1: integer;
begin
  Result := Fields.Champ1;
end;
 
procedure TFormHelper.SetChamp1(const Value: integer);
begin
 Fields.Champ1 := Value;
end;
 
procedure TForm4.FormClick(Sender: TObject);
begin
  ShowMessage(Form4.Champ1.ToString);
end;
 
procedure TForm4.FormCreate(Sender: TObject);
begin
  Form4.Champ1 := 1;  // <<<<<<<<<<<<<<<<<<<<<<<<<<
end;
 
end.

[Papy214]

Autre souci si je déplace le code dans FormClick

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
procedure TForm4.FormClick(Sender: TObject);
begin
  Form4.Champ1 := 1;
  ShowMessage(Form4.Champ1.ToString);
end;

La boite de dialogue affiche la valeur mais je peux cliquer sur le bouton Ok ,, il ne se passe rien.
impossible de sortir du showmessage :-(

[Andnotor]

Effectivement ça fonctionne parfaitement depuis 10.3. En dessous il semble qu'il y ait un problème avec la gestion des messages (la pile n'est plus vidée).

Ca fonctionne avec un TLabel mais pas un TWinControl. Il manquait sans doute une redirection vers la ProxyClass. L'unité RTTI a bien évolué depuis, je ne pense pas que je puisse y faire grand chose.

[Papy214]

c'est déjà bien si ça peut aider pour les versions supérieures