Klasse TPersistentEx zur Diskussion und Verbesserung

[michaott]

Hallo,

ich verwende häufig einfache Klassen auf Basis von TPersistent mit einfachen Datentypen. Hauptsächlich als Basis für Assign und Streamen. Da ich die Assign- und Streeaming Methoden immer manuell erstellen musste habe ich mir beiliegende Klasse TPersistenEx ausgedacht.

Ich bitte Interessierte um Kommentar und Optimierungsvorschläge.

Beispielcode zur Verwendung:

Delphi-Quellcode:

  TTestObject1 = Class(TPersistentEx)
  private
    FRechner: Double;
  published
    property Rechner: Double read FRechner write FRechner;
  End;

  TTestObject2 = Class(TPersistentEx)
  private
    FName: String;
    FAlter: Integer;
    FTestObject1: TTestObject1;
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Name: String read FName write FName;
    property Alter: Integer read FAlter write FAlter;
    property TestObject1: TTestObject1 read FTestObject1 write FTestObject1;
  End;

procedure TForm1.Button3Click(Sender: TObject);
var
  TestObject : TTestObject2;
  TestObject2 : TTestObject2;
  m : TMemoryStream;
begin
  TestObject := TTestObject2.Create;
  TestObject2 := TTestObject2.Create;
  m := TMemoryStream.Create;
  try
    with TestObject do begin
       FTestObject1.Rechner := 99.7;
       FName := 'Hallo';
       FAlter := 45;
    end;

    with TestObject2 do begin
       FTestObject1.Rechner := -6.7;
       FName := '';
       FAlter := -1;
    end;
    TestObject.AssignTo(TestObject2);

    TestObject.ToStream(m);
    m.Position := 0;
    TestObject2.FromStream(m);
  finally
    m.Free;
    TestObject.Free;
    TestObject2.Free;
  end;
end;

Zusätzlich noch die Frage weiß jemand wie man
   If (Object is TPersistentExList<T : TPersistentEx, constructor>) ... lösen kann?

Grüße Michael

[michaott]

Hallo,

erster Fehler, geht nur wenn property read und write hat, anbei Korrektur, diese übergeht read oder write only.

Grüße Michael

[michaott]

Hallo,

zweite Berichtigung

Grüße Michael

[michaott]

Hallo,

ich habe die Klasse erweitert, Es werden nun auch dynamische Array unterstützt und toXML und fromXML hinzugefügt.

Die Basis für XML ist VerySimpleXML v2.0.5 von Dennis Spreen
https://github.com/Dennis1000/verysimplexml

Delphi-Quellcode:

type

  TTestObject1 = Class(TPersistentEx)
  private
    FRechner: Double;
  published
    property Rechner: Double read FRechner write FRechner;
  End;

  TTestObject2 = Class(TPersistentEx)
  private
    FName: String;
    FAlter: Integer;
    FTestObject1: TTestObject1;
    FGetTest: String;
    Fcolor: COLORREF;
    FtestDWord: DWORD;
    Ftestp: UIntPtr;
    FArrTest: TArray<String>;
    FArrTestI: TArray<Integer>;
    function GetTest: String;
    procedure SetTest(const Value: String);
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Name: String read FName write FName;
    property Alter: Integer read FAlter write FAlter;
    property TestObject1: TTestObject1 read FTestObject1;
    property MyGetTest: String read GetTest write SetTest;
    property color : COLORREF read Fcolor write Fcolor;
    property testDWord : DWORD read FtestDWord write FtestDWord;
    property testp : UIntPtr read Ftestp write Ftestp;
    property ArrTest: TArray<String> read FArrTest write FArrTest;
    property ArrTestI: TArray<Integer> read FArrTestI write FArrTestI;
  End;


procedure TForm1.Button3Click(Sender: TObject);
var
  MyTestObject : TTestObject2;
  MyTestObject2 : TTestObject2;
  MyTestObject3 : TTestObject2;
  MyTestObject4 : TTestObject2;
  m : TMemoryStream;
  xml : TXmlVerySimple;
begin
  MyTestObject := TTestObject2.Create;
  MyTestObject2 := TTestObject2.Create;
  MyTestObject3 := TTestObject2.Create;
  MyTestObject4 := TTestObject2.Create;
  m := TMemoryStream.Create;
  xml := TXmlVerySimple.Create;
  try
    with MyTestObject do begin
       FTestObject1.Rechner := 99.7;
       FName := 'Hallo';
       FAlter := 45;
       MyGetTest := 'getTest';
       FColor := 99;
       FtestDWord := 123;
       FTestP := Cardinal(@MyTestObject);
       SetLength(FArrTest,5);
       FArrTest[0] := 'Hallo';
       FArrTest[4] := 'ts'',,c hau';
       SetLength(FArrTestI,6);
       FArrTestI[0] := 786;
       FArrTestI[4] := 985;
    end;
    with MyTestObject2 do begin
       FTestObject1.Rechner := -6.7;
       FName := '';
       FAlter := -1;
    end;
    MyTestObject.AssignTo(MyTestObject2);
    MyTestObject.ToStream(m);
    m.Position := 0;
    MyTestObject3.FromStream(m);
    MyTestObject.ToXML('MyTestObject', xml);
    MyTestObject4.FromXML('MyTestObject', xml);
    xml.SaveToFile('r:\Test.xml');
  finally
    m.Free;
    MyTestObject.Free;
    MyTestObject2.Free;
    MyTestObject3.Free;
    MyTestObject4.Free;
  end;
end;

Grüße Michael

[michaott]

Hallo,

für xml für erweiterte Datentypen noch TCustomAttribute eingeführt.

Delphi-Quellcode:

type
  TTestObject1 = Class(TPersistentEx)
  private
    FRechner: Double;
  published
    property Rechner: Double read FRechner write FRechner;
  End;

  TTestObject2 = Class(TPersistentEx)
  private
    FName: String;
    FAlter: Integer;
    FTestObject1: TTestObject1;
    FGetTest: String;
    Fcolor: COLORREF;
    FtestDWord: DWORD;
    Ftestp: UIntPtr;
    FArrTest: TArray<String>;
    FArrTestI: TArray<Integer>;
    FArrTestP: TArray<TAcPattern>;
    FDateTime: TDateTime;
    FIsBoolean: Boolean;
    function GetTest: String;
    procedure SetTest(const Value: String);
  public
    constructor Create;
    destructor Destroy; override;
    property ArrTestP: TArray<TAcPattern> read FArrTestP write FArrTestP;
  published
    property Name: String read FName write FName;
    property Alter: Integer read FAlter write FAlter;
    property TestObject1: TTestObject1 read FTestObject1;
    property MyGetTest: String read GetTest write SetTest;
    [xmlFlags(0, [xfdtHex])]
    property color : COLORREF read Fcolor write Fcolor;
    property testDWord : DWORD read FtestDWord write FtestDWord;
    property testp : UIntPtr read Ftestp write Ftestp;
    property ArrTest: TArray<String> read FArrTest write FArrTest;
    property ArrTestI: TArray<Integer> read FArrTestI write FArrTestI;
    [xmlFlags('22.04.2025 08:00:09', [xfdtDateTime])]
    property DateTime: TDateTime read FDateTime write FDateTime;
    [xmlFlags(True, [xfdtBoolean])]
    property IsBoolean: Boolean read FIsBoolean write FIsBoolean;
  End;

procedure TForm1.Button3Click(Sender: TObject);
var
  MyTestObject : TTestObject2;
  MyTestObject2 : TTestObject2;
  MyTestObject3 : TTestObject2;
  MyTestObject4 : TTestObject2;
  m : TMemoryStream;
  xml : TXmlVerySimple;
begin
  MyTestObject := TTestObject2.Create;
  MyTestObject2 := TTestObject2.Create;
  MyTestObject3 := TTestObject2.Create;
  MyTestObject4 := TTestObject2.Create;
  m := TMemoryStream.Create;
  xml := TXmlVerySimple.Create;
  try
    with MyTestObject do begin
       FTestObject1.Rechner := 99.7;
       FName := 'Hallo';
       FAlter := 45;
       MyGetTest := 'getTest';
       FColor := 99;
       FtestDWord := 123;
       FTestP := Cardinal(@MyTestObject);
       SetLength(FArrTest,5);
       FArrTest[0] := 'Hallo';
       FArrTest[4] := 'ts'',,c hau';
       SetLength(FArrTestI,6);
       FArrTestI[0] := 786;
       FArrTestI[4] := 985;
       DateTime := Now;
    end;
    with MyTestObject2 do begin
       FTestObject1.Rechner := -6.7;
       FName := '';
       FAlter := -1;
    end;
    MyTestObject.AssignTo(MyTestObject2);
    MyTestObject.ToStream(m);
    m.Position := 0;
    MyTestObject3.FromStream(m);
    MyTestObject.ToCfgXML('MyTestObject', xml);
    xml.SaveToFile('r:\TestCg.xml');
    MyTestObject4.FromCfgXML('MyTestObject', xml);
    xml.SaveToFile('r:\Test.xml');
  finally
    m.Free;
    MyTestObject.Free;
    MyTestObject2.Free;
    MyTestObject3.Free;
    MyTestObject4.Free;
  end;
end;

Grüße Michael

[michaott]

Hallo,

hier die vorerst letzte Version V1.0ß mit der Bitte um Test und Rückmeldung.

Delphi-Quellcode:

 Type
  TAcColor = Class(TPersistentEx)
  private
    FRed: Integer;
    FGreen: Integer;
    FBlue: Integer;
  published
    property Red: Integer read FRed write FRed;
    property Green: Integer read FGreen write FGreen;
    property Blue: Integer read FBlue write FBlue;
  End;

  TAcPattern  = Class(TPersistentEx)
  private
    FColor: TAcColor;
    FRaster: Integer;
  published
    constructor Create;
    destructor Destroy; override;
    property Color: TAcColor read FColor write FColor;
    property Raster: Integer read FRaster write FRaster;
  End;

  TStatArrayI = array[0..5,0..5]of Integer;
  TStatArrayS = array[0..5,0..5]of String;

  TStatartray = Array[0..2] of Integer;

  TTestObject2 = Class(TPersistentEx)
  private
    FName: String;
    FAlter: Integer;
    FTestObject1: TTestObject1;
    FGetTest: String;
    Fcolor: COLORREF;
    FtestDWord: DWORD;
    Ftestp: UIntPtr;
    FArrTest: TArray<String>;
    FArrTestI: TArray<Integer>;
    FArrTestP: TArray<TAcPattern>;
    FDateTime: TDateTime;
    FIsBoolean: Boolean;
    FObjectList: TPersistentExList;
    FObjectListArray: TArray<TPersistentExList>;
    function GetTest: String;
    procedure SetTest(const Value: String);
  public
    constructor Create;
    destructor Destroy; override;
  published
    property ObjectList: TPersistentExList read FObjectList write FObjectList;
    property ArrTestI: TArray<Integer> read FArrTestI write FArrTestI;
    property ArrTestP: TArray<TAcPattern> read FArrTestP write FArrTestP;
    property ArrTest: TArray<String> read FArrTest write FArrTest;
    property ObjectListArray: TArray<TPersistentExList> read FObjectListArray write FObjectListArray;
    property Name: String read FName write FName;
    property Alter: Integer read FAlter write FAlter;
    property TestObject1: TTestObject1 read FTestObject1 write FTestObject1;
    property MyGetTest: String read GetTest write SetTest;
    [xmlFlags(0, [xfdtHex])]
    property color : COLORREF read Fcolor write Fcolor;
    property testDWord : DWORD read FtestDWord write FtestDWord;
    property testp : UIntPtr read Ftestp write Ftestp;
    [xmlFlags('22.04.2025 08:00:09', [xfdtDateTime])]
    property DateTime: TDateTime read FDateTime write FDateTime;
    [xmlFlags(True, [xfdtBoolean])]
    property IsBoolean: Boolean read FIsBoolean write FIsBoolean;
  End;

procedure TForm1.Button3Click(Sender: TObject);

procedure doi(const AObject : String; const AAcPattern : TPersistentEx);
begin
   memo1.Lines.Add(Format('%s = %d',[AObject, TAcPattern(AAcPattern).FRaster]));
end;

var
  MyTestObject : TTestObject2;
  MyTestObject2 : TTestObject2;
  MyTestObject3 : TTestObject2;
  MyTestObject4 : TTestObject2;
  m : TFileStream;
  xml : TXmlVerySimple;
begin
  MyTestObject :=  TTestObject2.Create;
  MyTestObject2 := TTestObject2.Create;
  MyTestObject3 := TTestObject2.Create;
  MyTestObject4 := TTestObject2.Create;
  m := TFileStream.Create('r:\test.strm', fmCreate);
  xml := TXmlVerySimple.Create;
  try
    with MyTestObject do begin
       FTestObject1.Rechner := 99.7;
       FName := 'Hallo';
       FAlter := 45;
       MyGetTest := 'getTest';
       FColor := 99;
       FtestDWord := 123;
       FTestP := Cardinal(@MyTestObject);
       SetLength(FArrTest,5);
       FArrTest[0] := 'Hallo';
       FArrTest[4] := 'ts'',,c hau';
       SetLength(FArrTestI,6);
       FArrTestI[0] := 786;
       FArrTestI[4] := 985;
       DateTime := Now;
       SetLength(FArrTestP, 5);
       FArrTestP[2] := TAcPattern.Create;
       FArrTestP[2].FColor := TAcColor.Create;
       FArrTestP[2].FRaster := 8;
       SetLength(FObjectListArray, 5);
       FObjectListArray[4] := TPersistentExList.Create(True);
       var i := FObjectListArray[4].Add(TAcPattern.Create);
       TAcPattern(FObjectListArray[4][i]).FRaster := 956;
       i := FObjectListArray[4].Add(TAcPattern.Create);
       TAcPattern(FObjectListArray[4][i]).FRaster := 1234;
       IsBoolean := True;
    end;
    with MyTestObject2 do begin
       FTestObject1.Rechner := -6.7;
       FName := '';
       FAlter := -1;
    end;
    for var i  := 0 to MyTestObject.ObjectList.Count-1 do doi('ol_'+i.ToString,MyTestObject.ObjectList[i]);
    for var i  := 0 to MyTestObject.ObjectListArray[4].Count-1 do doi('ola4_'+i.ToString,MyTestObject.ObjectListArray[4][i]);
    MyTestObject.AssignTo(MyTestObject2);
    for var i  := 0 to MyTestObject2.ObjectList.Count-1 do doi('ol_'+i.ToString,MyTestObject2.ObjectList[i]);
    for var i  := 0 to MyTestObject2.ObjectListArray[4].Count-1 do doi('ola4_'+i.ToString,MyTestObject2.ObjectListArray[4][i]);
    MyTestObject.AssignTo(MyTestObject2);
    for var i  := 0 to MyTestObject2.ObjectList.Count-1 do doi('ol_'+i.ToString,MyTestObject2.ObjectList[i]);
    for var i  := 0 to MyTestObject2.ObjectListArray[4].Count-1 do doi('ola4_'+i.ToString,MyTestObject2.ObjectListArray[4][i]);
    MyTestObject.ToStream(m);
    m.Position := 0;
    MyTestObject3.FromStream(m);
    for var i  := 0 to MyTestObject3.ObjectList.Count-1 do doi('ol3_'+i.ToString,MyTestObject2.ObjectList[i]);
    for var i  := 0 to MyTestObject3.ObjectListArray[4].Count-1 do doi('ol3a4_'+i.ToString,MyTestObject2.ObjectListArray[4][i]);
    m.Position := 0;
    MyTestObject3.FromStream(m);
    for var i  := 0 to MyTestObject3.ObjectList.Count-1 do doi('ol3_'+i.ToString,MyTestObject2.ObjectList[i]);
    for var i  := 0 to MyTestObject3.ObjectListArray[4].Count-1 do doi('ol3a4_'+i.ToString,MyTestObject2.ObjectListArray[4][i]);
    m.Position := 0;
    MyTestObject2.ToXML('MyTestObject', xml);
    xml.SaveToFile('r:\TestCg.xml');
    MyTestObject4.FromXML('MyTestObject', xml);
    for var i  := 0 to MyTestObject4.ObjectList.Count-1 do doi('ol_'+i.ToString,MyTestObject4.ObjectList[i]);
    for var i  := 0 to MyTestObject4.ObjectListArray[4].Count-1 do doi('ola4_'+i.ToString,MyTestObject4.ObjectListArray[4][i]);
    MyTestObject4.FromXML('MyTestObject', xml);
    for var i  := 0 to MyTestObject4.ObjectList.Count-1 do doi('ol_'+i.ToString,MyTestObject4.ObjectList[i]);
    for var i  := 0 to MyTestObject4.ObjectListArray[4].Count-1 do doi('ola4_'+i.ToString,MyTestObject4.ObjectListArray[4][i]);

    xml.SaveToFile('r:\Test.xml');
  finally
    xml.Free;
    m.Free;
    MyTestObject.Free;
    MyTestObject2.Free;
    MyTestObject3.Free;
    MyTestObject4.Free;
  end;
end;

Grüße Michael

[freimatz]

Zitat von michaott:

Hallo,

hier die vorerst letzte Version V1.0ß mit der Bitte um Test und Rückmeldung.

Von mir nur mal soviel:
- Es fehlt die Doku (oder ich finde sie nicht)
- String und Class kleinschreiben.

[michaott]

Hallo,


Kurze Doku:

TPersistentEx als Erweiterung für TPersistent für Daten die zugewiesen, gestreamt, oder in xml gespeichert werden sollen.

Die Objekte auf der Basis von TPersistentEx haben ohne weitere Implementation Assign, Streaming und XML-Zuweisungs funktionalität für alle published Deklarierten Propertys. Bei den verwendeten Klassen muss die Basisklasse immer TPersistenEx sein.

Für Listen muss immer TPersistentExList verwendet werden, ansonsten werden keine Listen bearbeitet. Da ich noch keine Funktion zur as is für Generische Klassen (z.B. TPersistentExList<TestObject> is TPersistentExList<TPersistenEx>) gefunden haben muss immer die generische Klasse TPersistentExList = Class(TPersistentExList<TPersistenEx>)) verwendet werden.

Verwendete Klassen müssen mit RegisterClass(TKlassePersistentEx) registriert werden. Ansonsten gibt es eine Exception mit Zugriffsfehler beim Zurücklesen.

Grüße Michael

[michaott]

Hallo,

Nachtrag zur Doku:

verwendete Objekte müssen über RegisterClass registriert werden.

z.B. komplettes Unit mit:

Delphi-Quellcode:

unit UMeineObjekte;

....

procedure RegisterMyClasses;
var
  RttiCtx : TRttiContext;
begin
   RttiCtx := TRttiContext.Create;
   try
      for var t in RttiCtx.GetTypes  do begin
         if t.IsInstance then begin
            var o := t.AsInstance;
            var LUnitName := o.DeclaringUnitName;
            if t.TypeKind = tkClass then begin
               If LUnitName = 'UMeineObjekte' then begin
                  If (TRttiInstanceType(t).MetaclassType.InheritsFrom(TPersistentEx)) then begin
                     RegisterClass(TPersistentClass(TRttiInstanceType(t).MetaclassType));
                  end;
               end;
            end;
         end;
      end;
   finally
      RttiCtx.Free;
   end;
end;

initialization
   RegisterMyClasses;
end.

[michaott]

Hallo,

Fehler bei ToStream und FromStream

Code:

825c825
<        if not RttiProp.IsWritable then continue;
---
>        if not (RttiProp.IsWritable and RttiProp.IsReadable) then continue;
1216c1216
<          if not RttiProp.IsReadable then continue;
---
>          if not  (RttiProp.IsWritable and RttiProp.IsReadable) then continue;

Grüße Michael