TCollection und TCollectionItem

[Jens Schumann]

Hallo maximov,
ich habe an der unit noch etwas herumgefummelt.
Da TJsCollection eine published property einführt muss die Assign-Methode überschrieben werden.
In TmxJsCollection habe ich aus dem Parameter AsBinary eine property gemacht. Dann kann man in TJsCollection SaveToStream und LoadFromStream als virtual deklarieren und in TmxJsCollection überschreiben. Dann spart man sich in TmxJsCollection die Methoden SaveToFileEx und LoadFromFileEx.

Einverstanden ?

Delphi-Quellcode:

unit dpcollection;
// 
// written by Jens Schumann and MaxHub (maximov) 
// 

interface 

Uses SysUtils, Classes;

Type 

  TJsCollection = class(TCollection) 
  private 
    FCollectionname : String; 
    procedure SetCollectionname(const Value: String);
  public
    procedure Assign(Source : TPersistent); override;
    procedure SaveToFile(const Filename : TFilename); 
    procedure SaveToStream(Stream : TStream); virtual;
    procedure LoadFromFile(const Filename : TFilename); 
    procedure LoadFromStream(Stream : TStream); virtual;
  published
    property Collectionname : String read FCollectionname write SetCollectionname; 
  end;

  TmxJsCollection = class(TJsCollection)
  private
    FAsBinary : Boolean;
  public
    procedure LoadFromStream(aStream: TStream); override;
    procedure SaveToStream(aStream: TStream); override;
    property  AsBinary : Boolean read FAsBinary write FAsBinary;
  end;
      

  TWriterExt = class(TWriter) 
  public 
    
    procedure WriteCollection(Value: TCollection); 
    procedure WriteCollectionProperties(Value : TCollection); 
  end; 

  TReaderExt = class(TReader) 
  public 
    procedure ReadCollection(Value: TCollection); 
    procedure ReadCollectionProperties(Value: TCollection); 
  end; 


implementation 

uses TypInfo; 

const 
  iFilerBufferSize = 4096; 
  FilerSignatureEx: array[1..4] of Char = 'TPF0'; 

{ TJsCollection } 

procedure TJsCollection.Assign(Source: TPersistent);
begin
  If Source is TJsCollection then
    FCollectionname:=TJsCollection(Source).Collectionname;
  inherited Assign(Source);
end;

procedure TJsCollection.LoadFromFile(const Filename: TFilename);
var 
  FileStream : TFileStream; 
begin 
  Clear; 
  FileStream:=TFileStream.Create(Filename,fmOpenRead); 
  Try 
    LoadFromStream(FileStream); 
  Finally 
    FileStream.Free; 
    end; 
end; 

procedure TJsCollection.LoadFromStream(Stream: TStream); 
var 
  Reader  : TReaderExt; 
begin 
  Reader:=TReaderExt.Create(Stream,iFilerBufferSize); 
  Try 
    Reader.ReadCollection(Self); 
  Finally 
    Reader.Free; 
    end; 
end; 

procedure TJsCollection.SaveToFile(const Filename: TFilename); 
var 
  FileStream : TFileStream; 
begin 
  FileStream:=TFileStream.Create(Filename,fmCreate); 
  Try 
    SaveToStream(FileStream); 
  Finally 
    FileStream.Free; 
    end; 
end; 

procedure TJsCollection.SaveToStream(Stream: TStream); 
var 
  Writer       : TWriterExt; 
begin 
  Writer:=TWriterExt.Create(Stream,iFilerBufferSize); 
  Try 
    Writer.WriteCollection(Self); 
  Finally 
    Writer.Free; 
    end; 
end; 

procedure TJsCollection.SetCollectionname(const Value: String); 
begin 
  FCollectionname := Value; 
end;

{ TWriterExt }

procedure TWriterExt.WriteCollection(Value: TCollection); 
begin 
  WriteCollectionProperties(Value); 
  WriteStr('Items'); // wichtig für DFM-konformität
  inherited WriteCollection(Value); 
end; 

procedure TWriterExt.WriteCollectionProperties(Value: TCollection); 
begin 
  WriteProperties(Value); 
end; 

{ TReaderExt } 

procedure TReaderExt.ReadCollection(Value: TCollection); 
begin 
  ReadCollectionProperties(Value);  
  ReadStr; // wichtig für DFM-konformität
  ReadValue;  
  inherited ReadCollection(Value); 
end; 

procedure TReaderExt.ReadCollectionProperties(Value: TCollection); 
var 
  PropList   : TPropList; 
  PropCount  : Integer; 
  iCnt       : Integer; 
begin 
  PropCount:=GetPropList(Value.ClassInfo,tkProperties,@PropList); 
  For iCnt:=0 to PropCount-1 do 
    ReadProperty(Value); 
end; 


{ TmxJsCollection } 

procedure TmxJsCollection.LoadFromStream(aStream: TStream);
var Reader       : TReaderExt; 
    StreamInner  : TStream; 
    format       : TStreamOriginalFormat; 
    oldPos       : Int64; 
    SigBuffer    : array[1..4] of Char; 
    isBinary     : boolean; 
begin 
  // automatisch feststellen ob binär oder text 
  oldPos := aStream.Position; 
  aStream.ReadBuffer(SigBuffer[1],sizeOf(SigBuffer)); 
  isBinary := SigBuffer = FilerSignatureEx; 
  aStream.Position := oldPos; 
  
  if isBinary 
  then StreamInner := aStream 
  else StreamInner := TMemoryStream.Create;  
              
  try    
    // DFM-text parsen 
    if not isBinary then 
    begin 
      format := sofBinary;                              
      ObjectTextToBinary(aStream,StreamInner,format); 
      StreamInner.Position := 0; 
    end;  
                          
    Reader := TReaderExt.Create(StreamInner,iFilerBufferSize);      
    try 
      Reader.ReadSignature;  
      Reader.ReadStr; // ClassName            
      Reader.ReadStr; // Collectionname  

      Reader.ReadCollection(self);  

      Reader.ReadListEnd;                              
      Reader.ReadListEnd;            
    finally 
      Reader.Free; 
    end; 
  finally 
    if not isBinary then StreamInner.Free; 
  end; 
end; 

procedure TmxJsCollection.SaveToStream(aStream: TStream);
var Writer       : TWriterExt; 
    StreamInner  : TStream; 
    format       : TStreamOriginalFormat;          
begin              
  if FAsBinary
  then StreamInner := aStream 
  else StreamInner := TMemoryStream.Create;  
                
  try                                                      
    Writer := TWriterExt.Create(StreamInner,iFilerBufferSize);        
    try          
      Writer.WriteSignature; 
      Writer.WriteStr(ClassName);                    
      Writer.WriteStr(Collectionname);    

      Writer.WriteCollection(Self);

      Writer.WriteListEnd; 
      Writer.WriteListEnd;                                  
    finally 
      Writer.Free; 
    end; 
    // DFM-text konversion 
    if not FAsBinary then 
    begin 
      StreamInner.Position := 0;  
      format := sofText;                                
      ObjectBinaryToText(StreamInner,aStream,format); 
    end;        
  finally 
    if not FAsBinary then StreamInner.Free; 
  end; 
end; 

end.

Achtung: Entwickelt habe ich das ganze mit D7. Jetzt habe ich aber nur D5 zur Verfügung und musste feststellen: Wenn ein TCollectionItem im published Abschnitt eine TCollection property hat, werden deren published properties nicht gestreamt.
Ich vermute das es an D5 liegt. Ich werde mal über Pfingsten in die VCL-Source abtauchen und nachsehen an welcher Stelle sich D5 und D7 hier unterscheiden.

[Jens Schumann]

Hallo,
tatsächlich - es liegt an D5. Wenn man in der unit classes.pas die
Implementierung von WriteProperty vergleicht kann man erkennen, dass es dort unterschiede
gibt. Diese Unterschiede sorgen dafür dass wenn ein TCollectionItem im published Abschnitt eine TCollection property hat, deren published properties nicht gestreamt werden. Verdammt
Man könnte das Problem lösen wenn man TWriter.WriteProperties überschreibt. Leider handelt es sich hier um eine statische Methode. Das bedeutet aber nicht, dass der Code für D5 unbrachbar ist.

[maximov]

Zitat von Jens Schumann:

Hallo,
...
Man könnte das Problem lösen wenn man TWriter.WriteProperties überschreibt. Leider handelt es sich hier um eine statische Methode. Das bedeutet aber nicht, dass der Code für D5 unbrachbar ist.

Ja! das ist allerdings nervig. Leider wurden die filer-klassen nicht polymorphisch konzipiert ...hab ich mich auch schon sehr lange und viel drüber geärgert...aber egal so oft braucht auch keine n-dimensionalen collections und wenn, dann muss man halt D7 nehmen.


Ok...es gab noch ein paar kleines probleme, wenn man dynamische properties definieren will (DefineProperties()), da dein reader nur die anzahl der statisch definierten properties berücksichtigt. Hab das mal geändert. Jetzt kann man auch binäre und dynamische daten auf collection-ebene streamen (ich hoffe die funktionalität von TJsCollection wurde dadurch nicht betroffen, kannst ja mal testen und ggf. modifizieren)!

So könnte jetzt ein stream aussehen:

Delphi-Quellcode:

object test1: TmmxCollection
  globalInfo = 'hallo global'
  dynBinProp = {
    000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F
    202122232425262728292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F
    404142434445464748494A4B4C4D4E4F505152535455565758595A5B5C5D5E5F
    606162636465666768696A6B6C6D6E6F707172737475767778797A7B7C7D7E00}
  items = <
    item
      aBoolean = True
      anInteger = 42
      anExtended = 2123.000000000000000000
      anEnum = ffChildPos
      aSet = [ffChildPos, ffInline]
    end
    item
      aBoolean = False
      anInteger = 0
      anEnum = ffInherited
      aSet = []
      anImage.Data = {
        36030000424D3603000000000000360000002800000010000000100000000100
        18000000000000030000120B0000120B00000000000000000000FF00FFFF00FF
        FF00FFFF00FFFF00FFA0756E7443427443427443427443427443427443427443
        42744342744342FF00FFFF00FFFF00FFFF00FFFF00FFFF00FFA0756EFFF8E5F7
        EDD9F7EBD5F4E9D1F4E9D0F4E7CFF6EAD0EEDDC4754443FF00FFFF00FFFF00FF
        FF00FFFF00FFFF00FFA0756EF7EDDCF2D9BFF2D7BBF0D5BAEFD4B5EED3B2EED9
        BFE5D0BA754443FF00FFFF00FFFF00FFFF00FFFF00FFFF00FFA0756EFAEFDEFC
        C591FCC591FCC591FCC591FCC591FCC591E3D1BC754443FF00FFFF00FFA0756E
        744342744342744342A0756EFCF4E7F6D9BAF7D7B6F6D4B5F6D4B2F4D1ADF0DC
        C2E6D3C081524CFF00FFFF00FFA0756EFFF8E5F7EDD9F7EBD5A0756EFEF6EBF8
        DABCF8D9B8F8D8B7F7D5B6F7D4B2F3DEC7E7D7C581524DFF00FFFF00FFA0756E
        F7EDDCF2D9BFF2D7BBA0756EFEFAF2FCC591FCC591FCC591FCC591FCC591FCC5
        91EBDDCF8F5F5AFF00FFFF00FFA0756EFAEFDEFCC591FCC591A0756EFFFCFAFC
        E3CCFBE0C7FADEC6F8DEC4FCE2C6FCF0DEE1D7CE8F5E59FF00FFFF00FFA0756E
        FCF4E7F6D9BAF7D7B6A0756EFFFFFFFEFFFFFBFBFBFAF8F7FAFAF6E5D5D0C6B1
        AFA793959E675AFF00FFFF00FFA0756EFEF6EBF8DABCF8D9B8A0756EFFFFFFFF
        FFFFFFFEFEFFFCF8FFFEFAA0756EA0756EA0756EA0756EFF00FFFF00FFA0756E
        FEFAF2FCC591FCC591A0756EFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFA0756EE5A1
        54B6735DFF00FFFF00FFFF00FFA0756EFFFCFAFCE3CCFBE0C7A0756EA0756EA0
        756EA0756EA0756EA0756EA0756EAA6D68FF00FFFF00FFFF00FFFF00FFA0756E
        FFFFFFFEFFFFFBFBFBFAF8F7FAFAF6E5D5D0C6B1AFA793959E675AFF00FFFF00
        FFFF00FFFF00FFFF00FFFF00FFA0756EFFFFFFFFFFFFFFFEFEFFFCF8FFFEFAA0
        756EA0756EA0756EA0756EFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFA0756E
        FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFA0756EE5A154B6735DFF00FFFF00FFFF00
        FFFF00FFFF00FFFF00FFFF00FFA0756EA0756EA0756EA0756EA0756EA0756EA0
        756EAA6D68FF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FF}
    end
    item
      aBoolean = False
      anInteger = 42
      anExtended = 23.000000000000000000
      anEnum = ffChildPos
      aSet = []
    end>
end

Wird immer besser und hier der code:

Delphi-Quellcode:

unit dpCollection;
// 
// written by Jens Schumann and MaxHub (maximov) 
// 

interface 

Uses SysUtils, Classes;

Type 

  TJsCollection = class(TCollection) 
  private 
    FCollectionname : String; 
    procedure SetCollectionname(const Value: String); 
  public 
    procedure AfterConstruction; override;
    procedure Assign(Source : TPersistent); override; 
    procedure SaveToFile(const Filename : TFilename); 
    procedure SaveToStream(Stream : TStream); virtual; 
    procedure LoadFromFile(const Filename : TFilename); 
    procedure LoadFromStream(Stream : TStream); virtual;    
  published 
    property Collectionname : String read FCollectionname write SetCollectionname; 
  end; 

  TmxJsCollection = class(TJsCollection) 
  private 
    FAsBinary : Boolean; 
  protected
    procedure DefineProperties(Filer: TFiler); override;      
    procedure ReadItems(Reader: TReader);
    procedure WriteItems(Writer: TWriter);    
  public 
    procedure LoadFromStream(aStream: TStream); override; 
    procedure SaveToStream(aStream: TStream); override; 
    property  AsBinary : Boolean read FAsBinary write FAsBinary; 
  published
    property Collectionname stored false;
  end; 
      

  TWriterExt = class(TWriter) 
  public 
    procedure WriteCollection(Value: TCollection); 
    procedure WriteCollectionProperties(Value : TCollection); 
  end; 

  TReaderExt = class(TReader) 
  public 
    procedure ReadCollection(Value: TCollection); 
    procedure ReadCollectionProperties(Value: TCollection); 
  end; 


implementation 

uses TypInfo; 

const 
  iFilerBufferSize = 4096; 
  FilerSignatureEx: array[1..4] of Char = 'TPF0'; 
  cInvalidName = ' is not a valid CollectionName!';

{ TJsCollection } 

procedure TJsCollection.AfterConstruction;
begin
  inherited;
  FCollectionname := copy(className,2,length(className)-1)
end;

procedure TJsCollection.Assign(Source: TPersistent);
begin 
  If Source is TJsCollection then 
    FCollectionname:=TJsCollection(Source).Collectionname; 
  inherited Assign(Source); 
end; 

procedure TJsCollection.LoadFromFile(const Filename: TFilename); 
var 
  FileStream : TFileStream; 
begin 
  Clear; 
  FileStream:=TFileStream.Create(Filename,fmOpenRead); 
  Try 
    LoadFromStream(FileStream); 
  Finally 
    FileStream.Free; 
    end; 
end; 

procedure TJsCollection.LoadFromStream(Stream: TStream); 
var 
  Reader  : TReaderExt; 
begin 
  Reader:=TReaderExt.Create(Stream,iFilerBufferSize); 
  Try 
    Reader.ReadCollection(Self); 
  Finally 
    Reader.Free; 
    end; 
end; 

procedure TJsCollection.SaveToFile(const Filename: TFilename); 
var 
  FileStream : TFileStream; 
begin 
  FileStream:=TFileStream.Create(Filename,fmCreate); 
  Try 
    SaveToStream(FileStream); 
  Finally 
    FileStream.Free; 
    end; 
end; 

procedure TJsCollection.SaveToStream(Stream: TStream); 
var 
  Writer       : TWriterExt; 
begin 
  Writer:=TWriterExt.Create(Stream,iFilerBufferSize); 
  Try 
    Writer.WriteCollection(Self); 
  Finally 
    Writer.Free; 
    end; 
end; 

procedure TJsCollection.SetCollectionname(const Value: String); 
begin 
  if not IsValidIdent(Value)
  then raise exception.Create(#39+Value+#39+cInValidName)
  else FCollectionname := Value; 
end; 

{ TWriterExt } 

procedure TWriterExt.WriteCollection(Value: TCollection); 
begin 
  WriteCollectionProperties(Value); 
  inherited WriteCollection(Value); 
end; 

procedure TWriterExt.WriteCollectionProperties(Value: TCollection); 
begin 
  WriteProperties(Value); 
end; 

{ TReaderExt } 

procedure TReaderExt.ReadCollection(Value: TCollection); 
begin 
  ReadCollectionProperties(Value);  
  ReadValue;  
  inherited ReadCollection(Value); 
end; 

procedure TReaderExt.ReadCollectionProperties(Value: TCollection); 
begin 
  // das muss hier dynamisch bleiden, da sonst
  // dynamische properties nicht gestreamed werden können
  while not EndOfList do ReadProperty(value);
end; 


{ TmxJsCollection } 

procedure TmxJsCollection.DefineProperties(Filer: TFiler);
begin
  inherited;
  // collection-items standardmässig als dynamische 
  // property definieren!
  Filer.DefineProperty('items',ReadItems,WriteItems,count>0);
end;

procedure TmxJsCollection.ReadItems(Reader: TReader);
begin
  Reader.ReadValue;
  Reader.ReadCollection(self);
end;

procedure TmxJsCollection.WriteItems(Writer: TWriter);
begin
  Writer.WriteCollection(self);
end;

procedure TmxJsCollection.LoadFromStream(aStream: TStream);
var Reader       : TReaderExt; 
    StreamInner  : TStream; 
    format       : TStreamOriginalFormat; 
    oldPos       : Int64; 
    SigBuffer    : array[1..4] of Char; 
    isBinary     : boolean; 
begin 
  // automatisch feststellen ob binär oder text 
  oldPos := aStream.Position; 
  aStream.ReadBuffer(SigBuffer[1],sizeOf(SigBuffer)); 
  isBinary := SigBuffer = FilerSignatureEx; 
  aStream.Position := oldPos; 
  
  if isBinary 
  then StreamInner := aStream 
  else StreamInner := TMemoryStream.Create;  
              
  try    
    // DFM-text parsen 
    if not isBinary then 
    begin 
      format := sofBinary;                              
      ObjectTextToBinary(aStream,StreamInner,format); 
      StreamInner.Position := 0; 
    end;  
                          
    Reader := TReaderExt.Create(StreamInner,iFilerBufferSize);      
    try 
      Reader.ReadSignature;  
      Reader.ReadStr; // ClassName            
      FCollectionname := Reader.ReadStr; // Collectionname  

      Reader.ReadCollectionProperties(self);

      Reader.ReadListEnd;                              
      Reader.ReadListEnd;            
    finally 
      Reader.Free; 
    end; 
  finally 
    if not isBinary then StreamInner.Free; 
  end; 
end; 


procedure TmxJsCollection.SaveToStream(aStream: TStream);
var Writer       : TWriterExt; 
    StreamInner  : TStream; 
    format       : TStreamOriginalFormat;          
begin              
  if FAsBinary 
  then StreamInner := aStream 
  else StreamInner := TMemoryStream.Create;  
                
  try                                                      
    Writer := TWriterExt.Create(StreamInner,iFilerBufferSize);        
    try          
      Writer.WriteSignature; 
      Writer.WriteStr(ClassName);                    
      Writer.WriteStr(Collectionname);    

      Writer.WriteCollectionProperties(self);

      Writer.WriteListEnd; 
      Writer.WriteListEnd;                                  
    finally 
      Writer.Free; 
    end; 
    // DFM-text konversion 
    if not FAsBinary then 
    begin 
      StreamInner.Position := 0;  
      format := sofText;                                
      ObjectBinaryToText(StreamInner,aStream,format); 
    end;        
  finally 
    if not FAsBinary then StreamInner.Free; 
  end; 
end; 

end.

Was meinst du dazu?

[maximov]

Wollt nur mal schnell sagen, dass wir noch nicht fertig sind, wir entwickeln momentan per PN weiter und posten dann das 'endgültige' ergebnis dieser tollen unit

[Jens Schumann]

Zitat von maximov:

Wollt nur mal schnell sagen, dass wir noch nicht fertig sind, wir entwickeln momentan per PN weiter und posten dann das 'endgültige' ergebnis dieser tollen unit

Genau

Die D5 unit habe ich fertig und getest.
Mit der D7 unit habe ich das Problem, des mit unterschiedlichen TCollectionItem Nachfahren mal funktioniert und mal nicht

[maximov]

Zeig mal her. Ich kann ja mal ein härtetest machen