Referzen in ein Stream speichern

[negaH]

Delphi-Quellcode:

unit Unit2;

interface

uses SysUtils, Classes;

type
  TBase = class(TPersistent)
  protected
    procedure ReadData(Stream: TStream); dynamic; abstract;
    procedure WriteData(Stream: TStream); dynamic; abstract;
    procedure Changed; virtual;
  public
    class function LoadFromStream(Stream: TStream): TBase;
    procedure SaveToStream(Stream: TStream);
  end;

  TBaseClass = class of TBase;

  TPoint = class(TBase)
  private
    FX: Integer;
    FY: Integer;
    procedure SetX(Value: Integer);
    procedure SetY(Value: Integer);
  protected
    procedure ReadData(Stream: TStream); override;
    procedure WriteData(Stream: TStream); override;
  public
    constructor Create(APoint: TPoint); reintroduce; overload;
    constructor Create(AX, AY: Integer); reintroduce; overload;
    procedure Assign(Source: TPersistent); override;
  published
    property X: Integer read FX write SetX;
    property Y: Integer read FY write SetY;
  end;
 
  TKante = class(TBase)
  private
    FPoints: array[0..1] of TPoint;
    function GetPoint(Index: Integer): TPoint;
    procedure SetPoint(Index: Integer; Value: TPoint);
  protected
    procedure ReadData(Stream: TStream); override;
    procedure WriteData(Stream: TStream); override;
  public 
    constructor Create(AKante: TKante); reintroduce; overload;
    constructor Create(AStart, AStop: TPoint); reintroduce; overload;
    constructor Create(AStartX, AStartY, AStopX, AStopY: Integer); reintroduce; overload;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Start: TPoint index 0 read GetPoint write SetPoint;
    property Stop: TPoint index 1 read GetPoint write SetPoint;
  end;

procedure RegisterBaseClasses(const AClasses: array of TBaseClass);
function GetBaseClass(const AClassName: String): TBaseClass;

procedure SaveList(List: TList; Stream: TStream); // besser ist es eine eigene TList abzuleiten die nur TBaseClass enthalten kann
procedure LoadList(List: TList; Stream: TStream);

implementation

var
  FClassList: TList = nil;

procedure RegisterBaseClasses(const AClasses: array of TBaseClass);
var
  I: Integer;
begin
  Assert(FClassList <> nil);

  for I := Low(AClasses) to High(AClasses) do
    if not AClasses[I].InheritsFrom(TBase) then
      raise Exception.Create('ungültige Klasse in RegisterBaseClasses')
    else
      if GetBaseClass(AClasses[I].ClassName) <> nil then
        raise Exception.CreateFmt('eine Klasse mit Namen "%s" ist schon registriert', [AClasses[I].ClassName])
      else
        FClassList.Add(AClasses[I]);
end;

function GetBaseClass(const AClassName: String): TBaseClass;
var
  I: Integer;
begin
  Assert(FClassList <> nil);

  Result := nil;
  for I := 0 to FClassList.Count -1 do
    if AnsiCompareText(AClassName, TClass(FClassList[I]).ClassName) = 0 then
    begin
      Result := FClassList[I];
      Break;
    end;
end;

procedure SaveList(List: TList; Stream: TStream);
var
  I: Integer;
begin
  for I := 0 to List.Count -1 do
    TBase(List[I]).SaveToStream(Stream);
end;

procedure LoadList(List: TList; Stream: TStream);
begin
  while Stream.Position < Stream.Size do
    List.Add(TBase.LoadFromStream(Stream));
end;


// .TBase
procedure TBase.Changed;
begin
  // hier zb. ein NotifyEvent einbauen
end;

class function TBase.LoadFromStream(Stream: TStream): TBase;
var
  NewClass: TBaseClass;
  NewName: ShortString;
begin
  Stream.Read(NewName[0], 1);
  Stream.Read(NewName[1], Ord(NewName[0]));
  NewClass := GetBaseClass(NewName);
  if NewClass = nil then
    raise Exception.CreateFmt('Klasse "%s" ist nicht registriert', [NewName]);
  Result := NewClass.Create;
  Result.ReadData(Stream);
end;

procedure TBase.SaveToStream(Stream: TStream);
var
  NewName: ShortString;
begin
  NewName := ClassName;
  Stream.Write(NewName[0], Ord(NewName[0]) +1);
  WriteData(Stream);
end;

// .TPoint
procedure TPoint.SetX(Value: Integer);
begin
  if Value <> FX then
  begin
    FX := Value;
    Changed;
  end;
end;

procedure TPoint.SetY(Value: Integer);
begin
  if Value <> FY then
  begin
    FY := Value;
    Changed;
  end;
end;

procedure TPoint.ReadData(Stream: TStream);
begin
  Stream.Read(FX, SizeOf(FX));
  Stream.Read(FY, SizeOf(FY));
end;

procedure TPoint.WriteData(Stream: TStream);
begin
  Stream.Write(FX, SizeOf(FX));
  Stream.Write(FY, SizeOf(FY));
end;

constructor TPoint.Create(APoint: TPoint);
begin
  inherited Create;
  Assign(APoint);
end;

constructor TPoint.Create(AX, AY: Integer);
begin
  inherited Create;
  X := AX;
  Y := AY;
end;

procedure TPoint.Assign(Source: TPersistent);
var
  S: TPoint absolute Source;
begin
  if Source is TPoint then
  begin
    if (FX <> S.FX) or (FY <> S.Y) then
    begin
      FX := S.FX;
      FY := S.FY;
      Changed;
    end;
  end else
    if Source = nil then // bedeutet TPoint(nil) == TPoint(0,0) und ist eine Definitionssache des Programmierers
    begin
      if FX or FY <> 0 then // effizienter! als if (FX <> 0) or (FY <> 0) then
      begin
        FX := 0;
        FY := 0;
        Changed;
      end;
    end else inherited Assign(Source);
end;

// .TKante
function TKante.GetPoint(Index: Integer): TPoint;
begin
  if FPoints[Index] = nil then
    FPoints[Index] := TPoint.Create; // Auto-Allokation beim Zugriff auf Start oder Stop
  Result := FPoints[Index];
end;

procedure TKante.SetPoint(Index: Integer; Value: TPoint);
begin
  GetPoint(Index).Assign(Value); // WICHTIG! niemals ein Object setzen sondern immer dessen EIgenschaften kopieren
end;

procedure TKante.ReadData(Stream: TStream);
begin
  FreeAndNil(FPoints[0]);
  FreeAndNil(FPoints[1]);
  FPoints[0] := TPoint.LoadFromStream(Stream) as TPoint;
  FPoints[1] := TPoint.LoadFromStream(Stream) as TPoint;
end;
 
procedure TKante.WriteData(Stream: TStream);
begin
  Start.SaveToStream(Stream);
  Stop.SaveToStream(Stream);
end;

procedure TKante.Assign(Source: TPersistent);
begin
  if Source is TKante then
  begin
    Start.Assign(TKante(Source).Start);
    Stop.Assign(TKante(Source).Stop);
    Changed;
  end else
    if Source = nil then
    begin
      FreeAndNil(FPoints[0]);
      FreeAndNil(FPoints[1]);
      Changed;
    end else inherited Assign(Source);
end;

constructor TKante.Create(AStart,AStop: TPoint);
begin
  inherited Create;
  Start := AStart;
  Stop := AStop;
end;

constructor TKante.Create(AStartX,AStartY,AStopX,AStopY: Integer);
begin
  inherited Create;
  Start.X := AStartX;
  Start.Y := AStartY;
  Stop.X := AStopX;
  Stop.Y := AStopY;
end;

constructor TKante.Create(AKante: TKante);
begin
  inherited Create;
  Assign(AKante);
end;

destructor TKante.Destroy;
begin
  FreeAndNil(FPoints[0]);
  FreeAndNil(FPoints[1]);
  inherited Destroy;
end;

initialization
  FClassList := TList.Create;
  RegisterBaseClasses([TPoint, TKante]);
finalization
  FreeAndNil(FClassList);
end.

Mit wenigen Änderungen absolut lauffähig

Und ein Testcode

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
var
  List: TList;
  Stream: TMemoryStream;
  I: Integer;
begin
  Stream := TMemoryStream.Create;
  List := TList.Create;
  try
    for I := 0 to 9 do
      List.Add(TPoint.Create(I, I));
    for I := 0 to 9 do
      List.Add(TKante.Create(I, I, I, I));
    SaveList(List, Stream);

    Stream.SaveToFile('c:\test.bin');

    for I := 0 to List.Count -1 do
      TBase(List[I]).Free;
    List.Clear;
    Stream.Position := 0;
    LoadList(List, Stream);
  finally
    List.Free;
    Stream.Free;
  end;
end;

So, das macht aber mindestens 3 Biere, wenn ich den Stoff auf trinken würde

Gruß Hagen