Copier un objet dans un enfant

Version imprimable

Bonjour,
Je cherche un moyen d'automatiser la copie d'objet afin que lors de la création d'un objet enfant, je puisse utiliser un objet parent pour l'initialiser.
Je m'explique : j'ai un objet TParametreChamp de type TPersistent et son enfant TParametreChampEntier. Leurs prototypes se présentent comme ceci :

Code:

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
type
 
  TTypeParametre = (tpAlphabetique = 1, tpMemo = 2, tpTelephone = 3, tpCourriel = 4, tpDate = 5, tpBoolean = 6);
 
  TParametreChamp = class(TPersistent)
  private
    FID       : Int64;
    FLibelle  : string;
    FTypeChamp: TTypeParametre;
    FPosition : Int32;
    FLock     : Boolean;
  public
    constructor Create();
  published
    property ID: Int64
      read   FID
      write  FID;
    property Libelle: string
      read   FLibelle
      write  FLibelle;
    property TypeChamp: TTypeParametre
      read   FTypeChamp
      write  FTypeChamp;
    property Position: Int32
      read   FPosition
      write  FPosition;
    property Lock: Boolean
      read   FLock
      write  FLock;
  end;
 
  TParametreChampEntier = class(TParametreChamp)
  private
    FNomTable   : string;
    FNomChamp   : string;
    FNomTableID : string;
    FMaitreTable: string;
    FMaitreChamp: string;
  public
    constructor Create(); overload;
    constructor Create(const AParametreChamp: TParametreChamp); overload;
  published
    property NomTable: string
      read   FNomTable
      write  FNomTable;
    property NomChamp: string
      read   FNomChamp
      write  FNomChamp;
    property NomTableID: string
      read   FNomTableID
      write  FNomTableID;
    property MaitreTable: string
      read   FMaitreTable
      write  FMaitreTable;
    property MaitreChamp: string
      read   FMaitreChamp
      write  FMaitreChamp;
  end;

Lors de la création de chaque objets, j'initialise le contenu de leurs champs

Code:

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
{ TParametreChamp }
 
constructor TParametreChamp.Create();
begin
  inherited;
 
  FID        := 0;
  FLibelle   := '';
  FTypeChamp := tpAlphabetique;
  FPosition  := 0;
  FLock      := False;
end;
 
{ TParametreChampEntier }
 
constructor TParametreChampEntier.Create();
begin
  inherited;
 
  FNomTable    := '';
  FNomChamp    := '';
  FNomTableID  := '';
  FMaitreTable := '';
  FMaitreChamp := '';
end;
 
constructor TParametreChampEntier.Create(const AParametreChamp: TParametreChamp);
begin
  Create();
 
  AParametreChamp.AssignTo(TParametreChamp(Self));
end;

Mais lorsque je veux créer un objet TParametreChampEntier à partir d'un TParametreChamp, j'ai une erreur : "EConvertError : Impossible d'affecter TParametreChamp à TParametreChampEntier".

Quelqu'un aurait une idée de méthode, ou dois-je copier les valeurs de tous les champs un par un ?
Merci.

il te faut faire un override du AssignTo pour écrire ton propre code où tu devras copier les valeurs de tous les champs un par un

Code:

1
2
    procedure Assign(Source: TPersistent); override;
    procedure AssignTo(Dest: TPersistent); override;

Je suppose que tu veux recopier les parties communes de l'objet ancêtre vers l'objet hérité

pour faciliter la lecture du code j'aurais plutôt modifier Assign !

Assign c'est quand l'objet connait ses sources, souvent limité à un clone de soi-même
AssignTo c'est quand l'objet receveur ne connait pas toutes ses sources et c'est donc à l'objet devant être copier de savoir comment se copier vers l'objet Dest
Lorsque TPersistent.Assign ne sais pas quoi faire d'un objet, il fini par appeler AssignTo, c'est pour cela qu'une fois avoir gérer les sources connues, il faut appeler inherited Assign qui finira par appeler AssignTo.
Dans ton cas, c'est un clone d'un ancêtre vers un hérité, donc Assign

Code:

1
2
3
4
5
6
7
 
constructor TParametreChampEntier.Create(const AParametreChamp: TParametreChamp);
begin
  Create();
 
  Assign(AParametreChamp);
end;

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
procedure TParametreChamp.Assign(ASource: TPersistent);
begin
  if ASource is TParametreChamp then
  begin
    FLock := True;
    try
      FID := TParametreChamp(ASource).FID;
      FLibelle := TParametreChamp(ASource).FLibelle;
      FTypeChamp := TParametreChamp(ASource).FTypeChamp;
      FPosition := TParametreChamp(ASource).FPosition;
    finally
      FLock := False;
    end;
  end;
  else
    inherited Assign(ASource);
end;

Tu peux aussi utiliser des RTTI pour cloner un objet avec des propriétés publiées communes mais toujours dans l'idée d'un override du Assign ou du AssignTo
D'ailleurs, l'utilisation tu TPersistent n'a quasiment qu'un seul intérêt c'est les RTTI
J'ai beaucoup d'objet avec un Assign mais qui n'hérite que du TObject

Voici la version C++, j'ai le même en Delphi (plus lourde et plus spécifique à mes besoins de l'époque)

Code:

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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
 
//---------------------------------------------------------------------------
/*override*/void __fastcall TShaiORPersistent::Assign(TPersistent* Source)
{
  if ( ! IsRelation())
    this->PrimaryID = -1;
 
  if (Source && Source->InheritsFrom(__classid(TShaiORPersistent)))
  {
    this->DataSource = ((TShaiORPersistent*)Source)->DataSource;
    if ( ! this->DataSource)
      SetPublishedPropertiesFromPersistent(Source);
  }
  else if (Source && Source->InheritsFrom(__classid(TDataSet)))
  {
    this->DataSource = NULL;
    SetPublishedPropertiesFromDataSet((TDataSet*)Source);
  }
  else
    inherited::Assign(Source);
}
 
//---------------------------------------------------------------------------
/**
 * SetPublishedPropertiesFromPersistent fill object with another object
 * @return number of affected properties (-1 on null object)
 */
int TShaiORPersistent::SetPublishedPropertiesFromPersistent(TPersistent* APersistent)
{
  int Result = -1;
  if (APersistent)
  {
    Result = 0;
 
    TStringList *PropList = new TStringList();
    try
    {
      if (TShaiRTTIWrapper::GetPersistentProperties(APersistent->ClassType(), PropList))
      {
        for (int i = 0; i < PropList->Count; i++)
        {
          TPropertyName PropertyName = PropList->Strings[i];
 
          // Certaines propriétés publiées peuvent être en Lecture Seule, le chargement doit se faire manuellement !
          if (Typinfo::IsPublishedProp(this, PropertyName) && GetPropInfo(this, PropertyName)->SetProc)
          {
            Typinfo::SetPropValue(this, PropertyName, GetPropValue(APersistent, PropertyName, false));
            Result++;
          }
        }
      }
    }
    __finally
    {
      delete PropList;
    }
  }
 
  return Result;
}
 
//---------------------------------------------------------------------------
//                            TShaiRTTIWrapper                              -
//---------------------------------------------------------------------------
/*static*/ bool TShaiRTTIWrapper::GetPersistentProperties(TClass AClass, TStrings* AList, bool APersistentOnly/* = true*/)
{
  Typinfo::PPropInfo PropInfo;
 
  bool Result = AList && ( ! APersistentOnly || (APersistentOnly && AClass->InheritsFrom(__classid(TPersistent))));
  if (Result)
  {
    // Nettoyage de la Liste
    AList->Clear();
    // Récupération des Informations RTTI de la Classe
    PTypeInfo TypeInfo = (PTypeInfo)AClass->ClassInfo();
    // Obtention du Nombre de Propriété de la Classe
    int Count = Typinfo::GetTypeData(TypeInfo)->PropCount;
    Result = Count;
    if (Count)
    {
      // Allocation de la mémoire pour la Liste des Propriétés de la Classe
      Typinfo::PPropList PropList = (Typinfo::PPropList)malloc(Count * sizeof(Typinfo::PPropList));
      try
      {
        // Récupération du Tableur de Pointeur décrivant les Propriétés de la Classe
        Typinfo::GetPropInfos(TypeInfo, PropList);
        Typinfo::PPropInfo PropInfo;
        Typinfo::PPropInfo *PropItem = PropList->data;
        for (int i = 0; i < Count; i++)
        {
          // Récupération du Ieme Element décrivant l'une des Propriétés de la Classe
          PropInfo = *PropItem++;
 
          // Ajout du Nom de l'une des Propriétés de la Classe dans la Liste
          if (PropInfo)
            AList->Add(GetPropName(PropInfo));
        }
      }
      __finally
      {
        // Libération de la mémoire pour la Liste des Propriétés de la Classe
        free(PropList);
      }
    }
  }
 
  return Result;
}

Super cool :lun:
Ta méthode à l'air de marcher. Sauf pour mon champ de type énuméré, mais c'est un détail.

Je mets le code en Pascal Object si jamais ça intéresse des personnes.

Code:

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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
type
  TParametreChamp = class(TPersistent)
  private
    FID       : Int64;
    FLibelle  : string;
    FPosition : Int32;
    FLock     : Boolean;
  protected
    function SetPublishedPropertiesFromPersistent(var APersistent: TPersistent): Integer;
    procedure Assign(Source: TPersistent); override;
  public
    constructor Create();
  published
    property ID: Int64
      read   FID
      write  FID;
    property Libelle: string
      read   FLibelle
      write  FLibelle;
    property Position: Int32
      read   FPosition
      write  FPosition;
    property Lock: Boolean
      read   FLock
      write  FLock;
  end;
 
  TParametreChampEntier = class(TParametreChamp)
  private
    FNomTable   : string;
    FNomChamp   : string;
    FNomTableID : string;
    FMaitreTable: string;
    FMaitreChamp: string;
  public
    constructor Create(); overload;
    constructor Create(const AParametreChamp: TParametreChamp); overload;
  published
    property NomTable: string
      read   FNomTable
      write  FNomTable;
    property NomChamp: string
      read   FNomChamp
      write  FNomChamp;
    property NomTableID: string
      read   FNomTableID
      write  FNomTableID;
    property MaitreTable: string
      read   FMaitreTable
      write  FMaitreTable;
    property MaitreChamp: string
      read   FMaitreChamp
      write  FMaitreChamp;
  end;
 
{ TParametreChamp }
 
constructor TParametreChamp.Create();
begin
  inherited;
 
  FID        := 0;
  FLibelle   := '';
  FPosition  := 0;
  FLock      := False;
end;
 
function TParametreChamp.SetPublishedPropertiesFromPersistent(var APersistent: TPersistent): Integer;
var
  slPropList  : TStringList;
  TypeInfo    : PTypeInfo;
  PropList    : PPropList;
  PropInfo    : PPropInfo;
  PropertyName: string;
  Count       : Integer;
  i           : Integer;
begin
  Result := -1;
 
  if Assigned(APersistent) then
  begin
    Result     := 0;
    slPropList := TStringList.Create();
    try
      // Nettoyage de la liste
      slPropList.Clear();
 
      // Récupération des informations RTTI de la classe
      TypeInfo := APersistent.ClassInfo();
 
      // Obtention du nombre de propriété de la classe
      Count := TypeInfo.TypeData().PropCount;
 
      if Count > 0 then
      begin
        // Allocation de la mémoire pour la liste des propriétés de la classe
        PropList := AllocMem(SizeOf(PPropList));
 
        try
          // Récupération du tableau de pointeur décrivant les propriétés de la classe
          GetPropInfos(TypeInfo, PropList);
 
          for i := 0 to Count - 1 do
          begin
            // Récupération du ieme Element décrivant l'une des propriétés de la classe
            PropInfo := PropList[i];
 
            // Ajout du nom de l'une des propriétés de la classe dans la liste
            if Assigned(PropInfo) then
              slPropList.Add(GetPropName(PropInfo));
          end;
        finally
          FreeMem(PropList);
        end;
 
        for i := 0 to slPropList.Count - 1 do
        begin
          PropertyName := slPropList[i];
 
          // Certaines propriétés publiées peuvent être en lecture seule, le chargement doit se faire manuellement !
          if IsPublishedProp(Self, PropertyName) and Assigned(GetPropInfo(Self, PropertyName).SetProc) then
          begin
            SetPropValue(Self, PropertyName, GetPropValue(APersistent, PropertyName, False));
            Inc(Result);
          end;
        end;
      end;
    finally
      slPropList.Free();
    end;
  end;
end;
 
procedure TParametreChamp.Assign(Source: TPersistent);
begin
  if Assigned(Source) and Source.InheritsFrom(TParametreChamp) then
    SetPublishedPropertiesFromPersistent(Source)
  else
    inherited Assign(Source);
end;
 
{ TParametreChampEntier }
 
constructor TParametreChampEntier.Create();
begin
  inherited;
 
  FNomTable    := '';
  FNomChamp    := '';
  FNomTableID  := '';
  FMaitreTable := '';
  FMaitreChamp := '';
end;
 
constructor TParametreChampEntier.Create(const AParametreChamp: TParametreChamp);
begin
  Create();
 
  Self.Assign(AParametreChamp);
end;

Et donc, pour le Create(), il suffit de faire par exemple :

Code:

1
2
3
4
5
6
7
vParametreChamp           := TParametreChamp.Create();
vParametreChamp.ID        := 10;
vParametreChamp.Libelle   := 'Test';
vParametreChamp.Position  := 15;
vParametreChamp.Lock      := True;
 
vParametreChampEntier := TParametreChampEntier.Create(vParametreChamp);

Bonne journée ;)

13/04/2016, 18h47
ILP

Après un petit tour sur la documentation d'Embarcadero, j'ai constaté que les types énumérés qui ont des valeurs spécifiques, ne commençant pas à 0 et ne se suivant pas, n'ont pas de RTTI. C'est une limitation volontaire.
14/04/2016, 09h32
ShaiLeTroll

Modifie ton enum en ajoutant une valeur 0, c'est ce que je fais tout le temps !
Cela permet d'ailleurs d'avoir une valeur par défaut neutre,

Code:

TTypeParametre = (tpNone, tpAlphabetique, tpMemo, tpTelephone, tpCourriel, tpDate, tpBoolean);

Après ton enum c'est proche de

Code:

TFieldType = (ftUnknown, ftString, ftSmallint, ftInteger, ftWord, ...

Je sais que j'arrive après la bagarre mais quelle version est utilisée dans ce cas précis ?

A partir d'une certaine version de delphi on peut utiliser du json qui facilite la tâche mais ça ne fonctionne que sur les propriétés published. Et ça fonctionne aussi sur les propriétés enum

Code:

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
 
unit Unit8;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, rest.json, system.json;
 
type
  TRtt = (trUn, trDeux, trTrois);
 
  TTest = class
  private
    Frtt: Trtt;
  published
    property Rtt: Trtt read Frtt write Frtt;
  end;
 
  TForm8 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  end;
 
var
  Form8: TForm8;
 
implementation
 
{$R *.dfm}
 
procedure TForm8.Button1Click(Sender: TObject);
var
  Test: TTest;
  S: string;
begin
  Test := TTest.Create;
  Test.Rtt := Trtt.trDeux;
  S := Rest.json.TJson.ObjectToJsonString(Test);
  Test.Free;
  ShowMessage(S);
 
  Test := Rest.json.TJson.JsonToObject<TTest>(S);
  ShowMessage(Ord(Test.Rtt).ToString);
 
  Test.Free;
end;
 
end.

Sérialiser en chaine pour ensuite désérialiser pour faire un Assign n'est-ce pas un peu lourd ?
en XE2, il n'y a que le Data.DBXJSON.TJSONObject qui a été revu et amélioré dans System.JSON.TJSONObject de XE7

Pense à faire hériter de TPersistent ou de mettre la classe explicitement en M+, c'est nécessaire pour que le published fonctionne

Avant même le JSON, il existait déjà la sérialisation d'objet mais à partir de l'héritage d'un TComponent avec TStream.ReadComponent et TStream.WriteComponent qui n'est plus ni plus ni moins le format DFM !

Citation:

Envoyé par Papy214

Et ça fonctionne aussi sur les propriétés enum

Même contrainte, uniquement les enums
Normalement, on a une erreur "E2134: Le type '%s' n'a pas d'information de type (Delphi)"
Mais en XE, juste cela laisse 0 comme valeur de l'enum
et en XE7 c'est une violation d'accès sur une enum sans RTTI

Pour ceux qui n'ont que XE2, voici cela donne

XE2 {"type":"Unit8.TForm8.TTest","id":1,"fields":{"Frtt":"trDeux"}} !
XE7 {"rtt":"trDeux"} !

Code:

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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
unit ZooShaiVCL_JSON;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Data.DBXJSON, Data.DBXJSONReflect;
 
type
  TZooShaiVCLJSONForm = class(TForm)
    btnObjectToJSON: TButton;
    Memo: TMemo;
    procedure btnObjectToJSONClick(Sender: TObject);
  public
    type
      TRtt = (trUn, trDeux, trTrois);
 
      TTest = class(TPersistent)
      private
        Frtt: Trtt;
      published
        property Rtt: Trtt read Frtt write Frtt;
      end;
  end;
 
var
  ZooShaiVCLJSONForm: TZooShaiVCLJSONForm;
 
implementation
 
{$R *.dfm}
 
type
  TSLTJSONConverter = class(TJSONUnMarshal)
  public
    class function JsonStringToObject<T: class>(AJson: string): T; 
    class function ObjectToJsonString(AObject: TObject): string;
  end;
 
procedure TZooShaiVCLJSONForm.btnObjectToJSONClick(Sender: TObject);
var
  Test: TTest;
  S: string;
begin
  Test := TTest.Create;
  Test.Rtt := Trtt.trDeux;
  S := TSLTJSONConverter.ObjectToJsonString(Test);
  Test.Free;
  Memo.Lines.Add(S);
 
  Test := TSLTJSONConverter.JsonStringToObject<TTest>(S);
  Memo.Lines.Add(IntToStr(Ord(Test.Rtt)));
 
  Test.Free;
end;
 
class function TSLTJSONConverter.JsonStringToObject<T>(AJson: string): T;
var
  LJSONValue: Data.DBXJSON.TJsonValue;
  LJSONObject: Data.DBXJSON.TJSOnObject;
  LUnMarshaler: TSLTJSONConverter;
begin
  LJSONValue := Data.DBXJSON.TJSOnObject.ParseJSONValue(AJson);
  try
    if assigned(LJSONValue) and (LJSONValue is TJSOnObject) then
      LJSONObject := LJSONValue as TJSOnObject
    else
      Abort;
 
    LUnMarshaler := TSLTJSONConverter.Create;
    try
      Result := LUnMarshaler.CreateObject(LJSONObject) as T;
    finally
      FreeAndNil(LUnMarshaler);
    end;
  finally
    FreeAndNil(LJSONObject);
  end;
end;
 
class function TSLTJSONConverter.ObjectToJsonString(AObject: TObject): string;
var
  LMarshaler: Data.DBXJSONReflect.TJSONMarshal;
  LJSONObject: TJSOnObject;
begin
  LMarshaler := Data.DBXJSONReflect.TJSONMarshal.Create(TJSONConverter.Create);
  try
    LJSONObject := LMarshaler.Marshal(AObject) as TJSOnObject;
    try
      Result := LJSONObject.ToString;
    finally
      FreeAndNil(LJSONObject);
    end;
  finally
    FreeAndNil(LMarshaler);
  end;
end;
 
end.

Code:

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
 
object ZooShaiVCLJSONForm: TZooShaiVCLJSONForm
  Left = 326
  Top = 114
  Caption = 'JSON'
  ClientHeight = 192
  ClientWidth = 288
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  DesignSize = (
    288
    192)
  PixelsPerInch = 96
  TextHeight = 13
  object btnObjectToJSON: TButton
    Left = 8
    Top = 8
    Width = 146
    Height = 25
    Caption = 'btnObjectToJSON'
    TabOrder = 0
    OnClick = btnObjectToJSONClick
  end
  object Memo: TMemo
    Left = 8
    Top = 39
    Width = 272
    Height = 145
    Anchors = [akLeft, akTop, akRight, akBottom]
    Lines.Strings = (
      'Memo')
    TabOrder = 1
    WordWrap = False
  end
end

Je crois que je vais me créer unité "Common\SLT.Common.JSON.pas" pour conserver ce petit TSLTJSONConverter pour XE2