IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Codes sources à télécharger Delphi Discussion :

Ajouter des champs à un assistant de classe


Sujet :

Codes sources à télécharger Delphi

  1. #1
    Rédacteur/Modérateur
    Avatar de Andnotor
    Inscrit en
    Septembre 2008
    Messages
    5 738
    Détails du profil
    Informations personnelles :
    Localisation : Autre

    Informations forums :
    Inscription : Septembre 2008
    Messages : 5 738
    Points : 13 278
    Points
    13 278
    Par défaut Ajouter des champs à un assistant de classe
    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
    Fichiers attachés Fichiers attachés

  2. #2
    Membre expert
    Avatar de Charly910
    Homme Profil pro
    Ingénieur TP
    Inscrit en
    Décembre 2006
    Messages
    2 358
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations professionnelles :
    Activité : Ingénieur TP
    Secteur : Bâtiment Travaux Publics

    Informations forums :
    Inscription : Décembre 2006
    Messages : 2 358
    Points : 3 132
    Points
    3 132
    Par défaut
    Bonjour Andnotor,





    A+
    Charly

  3. #3
    Membre expert

    Homme Profil pro
    Développeur informatique
    Inscrit en
    Novembre 2007
    Messages
    3 431
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 62
    Localisation : France, Rhône (Rhône Alpes)

    Informations professionnelles :
    Activité : Développeur informatique

    Informations forums :
    Inscription : Novembre 2007
    Messages : 3 431
    Points : 3 068
    Points
    3 068
    Par défaut
    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.
    J-L aka Papy pour les amis

  4. #4
    Membre expert

    Homme Profil pro
    Développeur informatique
    Inscrit en
    Novembre 2007
    Messages
    3 431
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 62
    Localisation : France, Rhône (Rhône Alpes)

    Informations professionnelles :
    Activité : Développeur informatique

    Informations forums :
    Inscription : Novembre 2007
    Messages : 3 431
    Points : 3 068
    Points
    3 068
    Par défaut
    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 :-(
    J-L aka Papy pour les amis

  5. #5
    Rédacteur/Modérateur
    Avatar de Andnotor
    Inscrit en
    Septembre 2008
    Messages
    5 738
    Détails du profil
    Informations personnelles :
    Localisation : Autre

    Informations forums :
    Inscription : Septembre 2008
    Messages : 5 738
    Points : 13 278
    Points
    13 278
    Par défaut
    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.

  6. #6
    Membre expert

    Homme Profil pro
    Développeur informatique
    Inscrit en
    Novembre 2007
    Messages
    3 431
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 62
    Localisation : France, Rhône (Rhône Alpes)

    Informations professionnelles :
    Activité : Développeur informatique

    Informations forums :
    Inscription : Novembre 2007
    Messages : 3 431
    Points : 3 068
    Points
    3 068
    Par défaut
    c'est déjà bien si ça peut aider pour les versions supérieures
    J-L aka Papy pour les amis

Discussions similaires

  1. Réponses: 1
    Dernier message: 14/08/2006, 09h41
  2. Ajouter des champ dans une table avec une procedure sp
    Par Abdou1 dans le forum MS SQL Server
    Réponses: 5
    Dernier message: 26/07/2006, 18h32
  3. [PHP-JS] ajouter des champ en cliquant sur un bouton?
    Par einsteineuzzz dans le forum Langage
    Réponses: 3
    Dernier message: 29/06/2006, 17h36
  4. Ajouter des champs dans un formulaire
    Par Luffy Duck dans le forum Général JavaScript
    Réponses: 1
    Dernier message: 18/05/2006, 10h30
  5. Ajouter des CHAMPS dans une table via ASP
    Par hysteresis dans le forum Access
    Réponses: 1
    Dernier message: 27/09/2005, 15h39

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo